source: FOIAVistA/trunk/r/CMOP-PSX/PSXLBLU.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1PSXLBLU ;BIR/HTW,BAB-CMOP Host Label Print..Blackline Resolver ;[ 05/01/97 11:47 AM ]
2 ;;2.0;CMOP;**1**;11 Apr 97
3BLR ;BLACK LINE RESOLVER
4 L +^PSX(553):1 I '$T D MSG Q
5 I ^PSX(553,1,"S")="R" D MSG Q
6 G:'$D(^PSX(554,"AB")) BLR1
7 S R554=$O(^PSX(554,"AB",""))
8 I $P($G(^PSX(554,1,1,R554,0)),"^",4)="R" S ZH="F" D MSG Q
9BLR1 I ^PSX(553,1,"S")="S" S ^PSX(553,1,"P")="R"
10 L -^PSX(553)
11 W @IOF
12 S ZEND=999999999,PSXBLR=1
13 W ?25,"CMOP LABEL RESTART UTILITY"
14 W !!,"To run the Label Restart Utility you will need the Rx number of the last"
15 W !," USEABLE Rx that printed, as well as the CMOP Order # where the"
16 W !,"error occurred.",!
17 S DIR(0)="Y",DIR("A")="Did the error occur during Reprint",DIR("B")="NO"
18 S DIR("?")="If the error occurred while reprinting labels answer YES, otherwise press enter."
19 D ^DIR K DIR G:$D(DIRUT) END1
20 S:$G(Y)=1 REPRINT=1 K Y
21ORDER W !
22 S DIC=552.2,DIC(0)="AEQMZ",DIC("A")="Enter Beginning CMOP Order #: "
23 D ^DIC K DIC G:$E(X)["^"!($D(DUOUT))!($D(DTOUT)) STOP
24 I ""[X W !,"This is a required response. Enter ""^"" to Exit" G ORDER
25 S (PSXBEG,ZA2)=+Y,BATREF=$P($P(Y,U,2),"-")_"-"_$P($P(Y,U,2),"-",2)
26 S N514=$O(^PSX(552.1,"B",BATREF,""))
27ORD1 S DIC=552.2,DIC(0)="AEQMZ",DIC("A")="Enter Ending CMOP Order #: "
28 D ^DIC K DIC G:$E(X)["^"!($D(DUOUT))!($D(DTOUT)) STOP
29 I ""[X S PSXEND=PSXBEG K Y G RX
30 S PSXEND=+Y
31RX I PSXEND<PSXBEG W !,"Ending order # MUST FOLLOW beginning order #. Try again." K PSXEND G ORD1
32 W !
33 S DIR(0)="FO^1:999999999"
34 S DIR("A")="Enter the last USABLE Rx number printed or 'RETURN' to start at the first Rx in order"
35 S DIR("?")="^D HELP^PSXLBLU"
36 D ^DIR K DIR G:$D(DUOUT)!($D(DTOUT)) STOP
37 I $G(Y)="" S RESET="TOP" G D1
38 S RXX=$TR(Y," ","")
39FIND S CNT=1,CNT1=0
40 F C=1:0 S C=$O(^PSX(552.2,ZA2,"T",C)) Q:'C S J=^(C,0) I $P(J,"|")="ZX1" D
41 .S RXY=$P(J,"|",2) I RXX=RXY S RESET=CNT
42 .S CNT=CNT+1,CNT1=CNT1+1
43 I '$G(RESET) W !!,"NO MATCHING RX NUMBER FOUND...Searching",! H 2 D HELP G RX
44 I CNT1=1 W !!,"There is only one Rx in this order. To print it, press RETURN at the prompt." G RX
45 I $G(RESET)=CNT1 W !!,"You have chosen the last Rx in this order. If you want to print this Rx, enter the Rx preceding this Rx within the order or press RETURN to print the entire order." G RX
46D1 D DEVICE^PSXLBL S ^PSX(553,1,"P")="S"
47STOP ;
48 I ^PSX(553,1,"P")="R" S ^PSX(553,1,"P")="S"
49 K C,DIC,DIR,X,Y,ZX,BATREF1,OUT,Z1,NODE,TRUG,J,N,ZA2,RXX,RXY,Z,ZEND
50 K CNT,REPRINT,RESET,BATREF,N514,PSXBAR,PSXLAP,CNT1
51 K DTOUT,DUOUT,DIRUT,DIROUT,PSXBEG,PSXEND,PSXBLR,R554
52 Q
53HELP ;
54 S Z=ZA2-1,ZEND=ZA2
55SKIP ;
56 F S Z=$O(^PSX(552.2,Z)) Q:'Z!(Z>ZEND) S BATREF1=$P(^(Z,0),U) D S1 Q:$G(OUT)
57 Q
58S1 W @IOF
59 W !,"You selected CMOP order # ",BATREF1
60 W !,"If this is correct, please choose the last USABLE Rx that printed"
61 W !,"from the following list: "
62S2 F Z1=0:0 S Z1=$O(^PSX(552.2,Z,"T",Z1)) Q:'Z1 S NODE=^(Z1,0) D Q:$G(OUT)
63 .I $P(NODE,"|")="PID" W !!,$TR($P(NODE,"|",6),"^",","),?30 Q
64 .I $P(NODE,"|")="RX1" S TRUG=$P($P(NODE,"|",15),"^",2) Q
65 .I $P(NODE,"|")="ZX1" W !,$P(NODE,"|",2),?15,TRUG
66 .I $Y>20 S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) OUT=1 W @IOF
67 Q
68PRINT ;
69 S A0="",AZ1=BATREF_"-",^TMP($J,PSXBEG)=""
70 F S A0=$O(^PSX(552.2,"B",A0)) Q:($G(A0)']"") I A0[AZ1 D
71 .F A1=0:0 S A1=$O(^PSX(552.2,"B",A0,A1)) Q:'A1!(A1>PSXEND) D
72 ..I A1>PSXBEG S ^TMP($J,A1)=""
73 ..K AZ
74 K A1,ZA2,A0,AZ1
75MAIN ;
76 F A1=0:0 S A1=$O(^TMP($J,A1)) Q:'A1 S ZA2=A1-1 D MAIN^PSXLBL1
77F514 D NOW^%DTC S (Y,RNOW1)=% X ^DD("DD") S RNOW=$P(Y,":",1,2) K Y,%,DD,DO
78 S DA=ZA2
79 I $G(REPRINT) D G F1
80 .I '$D(^PSX(552.1,N514,3,0)) S ^PSX(552.1,N514,3,0)="^552.115^^"
81 .S DA(1)=N514,DIC(0)="LMZ",DIC="^PSX(552.1,DA(1),3,",X="BATCH REPRINTED by "_$P($G(^VA(200,DUZ,0)),"^")_" on "_RNOW,DLAYGO=552
82 I '$D(^PSX(552.1,N514,4,0)) S ^PSX(552.1,N514,4,0)="^552.117D^^"
83 S DA(1)=N514,DIC(0)="LMZ",DIC="^PSX(552.1,DA(1),4,",X=RNOW1 S DIC("DR")="1////"_DUZ,DLAYGO=552
84F1 D FILE^DICN K DIC,X,DLAYGO
85F2 I '$D(^PSX(552.2,"AQ",BATREF)),($P($G(^PSX(552.1,N514,0)),"^",2)=2) D
86 .S $P(^PSX(552.1,N514,0),"^",2)=3,$P(^(0),"^",6)=RNOW1
87 .S DIK="^PSX(552.1,",DA=N514 D IX^DIK K DIK,DA
88 .S $P(^PSX(554,1,0),"^",4)=BATREF
89 S PSXDA=N514 D ACK^PSXNOTE
90F553 S ^PSX(553,1,"P")="S"
91END ;
92 K ^PSX(552.1,"APR",BATREF)
93 K NOW,BDAT,BDATE,EDAT,EDATE,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,N2,N3,SITE
94 K ZA2,ADDR,AZ,AZ1,B,C1,C2,DIE,DR,I,N4,N514,Q1,TODAY,RNOW,RX1,ZX,BAR
95 K S,SADD1,SADD2,SCITY,ZZT,F,SIGN,SNAME,SSN,SSTATE,STEL,SZIP,TEMP,TODAY
96 K PSXBAR0,PSXBAR1,R554,DIRUT,DTOUT,DUOUT,DIROUT,RNOW1
97 Q
98MSG W !!,"Labels may NOT be printed while the CMOP "_$S($G(ZH)="F":"Background Filer ",1:"Interface ")_"is running.",!!,"Please try again,later.",!! L -^PSX(553)
99 K ZH,R554
100 Q
101END1 K PSXBEG,PSXEND,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,A,CT,CH1,L,PSXST,ZY
102 K IEN14,CNT,R554,PSXBLR
103 Q
Note: See TracBrowser for help on using the repository browser.