- PSXLBLU ;BIR/HTW,BAB-CMOP Host Label Print..Blackline Resolver ;[ 05/01/97 11:47 AM ]
- ;;2.0;CMOP;**1**;11 Apr 97
- BLR ;BLACK LINE RESOLVER
- L +^PSX(553):1 I '$T D MSG Q
- I ^PSX(553,1,"S")="R" D MSG Q
- G:'$D(^PSX(554,"AB")) BLR1
- S R554=$O(^PSX(554,"AB",""))
- I $P($G(^PSX(554,1,1,R554,0)),"^",4)="R" S ZH="F" D MSG Q
- BLR1 I ^PSX(553,1,"S")="S" S ^PSX(553,1,"P")="R"
- L -^PSX(553)
- W @IOF
- S ZEND=999999999,PSXBLR=1
- W ?25,"CMOP LABEL RESTART UTILITY"
- W !!,"To run the Label Restart Utility you will need the Rx number of the last"
- W !," USEABLE Rx that printed, as well as the CMOP Order # where the"
- W !,"error occurred.",!
- S DIR(0)="Y",DIR("A")="Did the error occur during Reprint",DIR("B")="NO"
- S DIR("?")="If the error occurred while reprinting labels answer YES, otherwise press enter."
- D ^DIR K DIR G:$D(DIRUT) END1
- S:$G(Y)=1 REPRINT=1 K Y
- ORDER W !
- S DIC=552.2,DIC(0)="AEQMZ",DIC("A")="Enter Beginning CMOP Order #: "
- D ^DIC K DIC G:$E(X)["^"!($D(DUOUT))!($D(DTOUT)) STOP
- I ""[X W !,"This is a required response. Enter ""^"" to Exit" G ORDER
- S (PSXBEG,ZA2)=+Y,BATREF=$P($P(Y,U,2),"-")_"-"_$P($P(Y,U,2),"-",2)
- S N514=$O(^PSX(552.1,"B",BATREF,""))
- ORD1 S DIC=552.2,DIC(0)="AEQMZ",DIC("A")="Enter Ending CMOP Order #: "
- D ^DIC K DIC G:$E(X)["^"!($D(DUOUT))!($D(DTOUT)) STOP
- I ""[X S PSXEND=PSXBEG K Y G RX
- S PSXEND=+Y
- RX I PSXEND<PSXBEG W !,"Ending order # MUST FOLLOW beginning order #. Try again." K PSXEND G ORD1
- W !
- S DIR(0)="FO^1:999999999"
- S DIR("A")="Enter the last USABLE Rx number printed or 'RETURN' to start at the first Rx in order"
- S DIR("?")="^D HELP^PSXLBLU"
- D ^DIR K DIR G:$D(DUOUT)!($D(DTOUT)) STOP
- I $G(Y)="" S RESET="TOP" G D1
- S RXX=$TR(Y," ","")
- FIND S CNT=1,CNT1=0
- F C=1:0 S C=$O(^PSX(552.2,ZA2,"T",C)) Q:'C S J=^(C,0) I $P(J,"|")="ZX1" D
- .S RXY=$P(J,"|",2) I RXX=RXY S RESET=CNT
- .S CNT=CNT+1,CNT1=CNT1+1
- I '$G(RESET) W !!,"NO MATCHING RX NUMBER FOUND...Searching",! H 2 D HELP G RX
- I CNT1=1 W !!,"There is only one Rx in this order. To print it, press RETURN at the prompt." G RX
- 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
- D1 D DEVICE^PSXLBL S ^PSX(553,1,"P")="S"
- STOP ;
- I ^PSX(553,1,"P")="R" S ^PSX(553,1,"P")="S"
- K C,DIC,DIR,X,Y,ZX,BATREF1,OUT,Z1,NODE,TRUG,J,N,ZA2,RXX,RXY,Z,ZEND
- K CNT,REPRINT,RESET,BATREF,N514,PSXBAR,PSXLAP,CNT1
- K DTOUT,DUOUT,DIRUT,DIROUT,PSXBEG,PSXEND,PSXBLR,R554
- Q
- HELP ;
- S Z=ZA2-1,ZEND=ZA2
- SKIP ;
- F S Z=$O(^PSX(552.2,Z)) Q:'Z!(Z>ZEND) S BATREF1=$P(^(Z,0),U) D S1 Q:$G(OUT)
- Q
- S1 W @IOF
- W !,"You selected CMOP order # ",BATREF1
- W !,"If this is correct, please choose the last USABLE Rx that printed"
- W !,"from the following list: "
- S2 F Z1=0:0 S Z1=$O(^PSX(552.2,Z,"T",Z1)) Q:'Z1 S NODE=^(Z1,0) D Q:$G(OUT)
- .I $P(NODE,"|")="PID" W !!,$TR($P(NODE,"|",6),"^",","),?30 Q
- .I $P(NODE,"|")="RX1" S TRUG=$P($P(NODE,"|",15),"^",2) Q
- .I $P(NODE,"|")="ZX1" W !,$P(NODE,"|",2),?15,TRUG
- .I $Y>20 S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) OUT=1 W @IOF
- Q
- PRINT ;
- S A0="",AZ1=BATREF_"-",^TMP($J,PSXBEG)=""
- F S A0=$O(^PSX(552.2,"B",A0)) Q:($G(A0)']"") I A0[AZ1 D
- .F A1=0:0 S A1=$O(^PSX(552.2,"B",A0,A1)) Q:'A1!(A1>PSXEND) D
- ..I A1>PSXBEG S ^TMP($J,A1)=""
- ..K AZ
- K A1,ZA2,A0,AZ1
- MAIN ;
- F A1=0:0 S A1=$O(^TMP($J,A1)) Q:'A1 S ZA2=A1-1 D MAIN^PSXLBL1
- F514 D NOW^%DTC S (Y,RNOW1)=% X ^DD("DD") S RNOW=$P(Y,":",1,2) K Y,%,DD,DO
- S DA=ZA2
- I $G(REPRINT) D G F1
- .I '$D(^PSX(552.1,N514,3,0)) S ^PSX(552.1,N514,3,0)="^552.115^^"
- .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
- I '$D(^PSX(552.1,N514,4,0)) S ^PSX(552.1,N514,4,0)="^552.117D^^"
- S DA(1)=N514,DIC(0)="LMZ",DIC="^PSX(552.1,DA(1),4,",X=RNOW1 S DIC("DR")="1////"_DUZ,DLAYGO=552
- F1 D FILE^DICN K DIC,X,DLAYGO
- F2 I '$D(^PSX(552.2,"AQ",BATREF)),($P($G(^PSX(552.1,N514,0)),"^",2)=2) D
- .S $P(^PSX(552.1,N514,0),"^",2)=3,$P(^(0),"^",6)=RNOW1
- .S DIK="^PSX(552.1,",DA=N514 D IX^DIK K DIK,DA
- .S $P(^PSX(554,1,0),"^",4)=BATREF
- S PSXDA=N514 D ACK^PSXNOTE
- F553 S ^PSX(553,1,"P")="S"
- END ;
- K ^PSX(552.1,"APR",BATREF)
- K NOW,BDAT,BDATE,EDAT,EDATE,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,N2,N3,SITE
- K ZA2,ADDR,AZ,AZ1,B,C1,C2,DIE,DR,I,N4,N514,Q1,TODAY,RNOW,RX1,ZX,BAR
- K S,SADD1,SADD2,SCITY,ZZT,F,SIGN,SNAME,SSN,SSTATE,STEL,SZIP,TEMP,TODAY
- K PSXBAR0,PSXBAR1,R554,DIRUT,DTOUT,DUOUT,DIROUT,RNOW1
- Q
- MSG 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)
- K ZH,R554
- Q
- END1 K PSXBEG,PSXEND,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,A,CT,CH1,L,PSXST,ZY
- K IEN14,CNT,R554,PSXBLR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXLBLU 4848 printed Feb 18, 2025@23:10:48 Page 2
- PSXLBLU ;BIR/HTW,BAB-CMOP Host Label Print..Blackline Resolver ;[ 05/01/97 11:47 AM ]
- +1 ;;2.0;CMOP;**1**;11 Apr 97
- BLR ;BLACK LINE RESOLVER
- +1 LOCK +^PSX(553):1
- IF '$TEST
- DO MSG
- QUIT
- +2 IF ^PSX(553,1,"S")="R"
- DO MSG
- QUIT
- +3 if '$DATA(^PSX(554,"AB"))
- GOTO BLR1
- +4 SET R554=$ORDER(^PSX(554,"AB",""))
- +5 IF $PIECE($GET(^PSX(554,1,1,R554,0)),"^",4)="R"
- SET ZH="F"
- DO MSG
- QUIT
- BLR1 IF ^PSX(553,1,"S")="S"
- SET ^PSX(553,1,"P")="R"
- +1 LOCK -^PSX(553)
- +2 WRITE @IOF
- +3 SET ZEND=999999999
- SET PSXBLR=1
- +4 WRITE ?25,"CMOP LABEL RESTART UTILITY"
- +5 WRITE !!,"To run the Label Restart Utility you will need the Rx number of the last"
- +6 WRITE !," USEABLE Rx that printed, as well as the CMOP Order # where the"
- +7 WRITE !,"error occurred.",!
- +8 SET DIR(0)="Y"
- SET DIR("A")="Did the error occur during Reprint"
- SET DIR("B")="NO"
- +9 SET DIR("?")="If the error occurred while reprinting labels answer YES, otherwise press enter."
- +10 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END1
- +11 if $GET(Y)=1
- SET REPRINT=1
- KILL Y
- ORDER WRITE !
- +1 SET DIC=552.2
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Enter Beginning CMOP Order #: "
- +2 DO ^DIC
- KILL DIC
- if $EXTRACT(X)["^"!($DATA(DUOUT))!($DATA(DTOUT))
- GOTO STOP
- +3 IF ""[X
- WRITE !,"This is a required response. Enter ""^"" to Exit"
- GOTO ORDER
- +4 SET (PSXBEG,ZA2)=+Y
- SET BATREF=$PIECE($PIECE(Y,U,2),"-")_"-"_$PIECE($PIECE(Y,U,2),"-",2)
- +5 SET N514=$ORDER(^PSX(552.1,"B",BATREF,""))
- ORD1 SET DIC=552.2
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Enter Ending CMOP Order #: "
- +1 DO ^DIC
- KILL DIC
- if $EXTRACT(X)["^"!($DATA(DUOUT))!($DATA(DTOUT))
- GOTO STOP
- +2 IF ""[X
- SET PSXEND=PSXBEG
- KILL Y
- GOTO RX
- +3 SET PSXEND=+Y
- RX IF PSXEND<PSXBEG
- WRITE !,"Ending order # MUST FOLLOW beginning order #. Try again."
- KILL PSXEND
- GOTO ORD1
- +1 WRITE !
- +2 SET DIR(0)="FO^1:999999999"
- +3 SET DIR("A")="Enter the last USABLE Rx number printed or 'RETURN' to start at the first Rx in order"
- +4 SET DIR("?")="^D HELP^PSXLBLU"
- +5 DO ^DIR
- KILL DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- GOTO STOP
- +6 IF $GET(Y)=""
- SET RESET="TOP"
- GOTO D1
- +7 SET RXX=$TRANSLATE(Y," ","")
- FIND SET CNT=1
- SET CNT1=0
- +1 FOR C=1:0
- SET C=$ORDER(^PSX(552.2,ZA2,"T",C))
- if 'C
- QUIT
- SET J=^(C,0)
- IF $PIECE(J,"|")="ZX1"
- Begin DoDot:1
- +2 SET RXY=$PIECE(J,"|",2)
- IF RXX=RXY
- SET RESET=CNT
- +3 SET CNT=CNT+1
- SET CNT1=CNT1+1
- End DoDot:1
- +4 IF '$GET(RESET)
- WRITE !!,"NO MATCHING RX NUMBER FOUND...Searching",!
- HANG 2
- DO HELP
- GOTO RX
- +5 IF CNT1=1
- WRITE !!,"There is only one Rx in this order. To print it, press RETURN at the prompt."
- GOTO RX
- +6 IF $GET(RESET)=CNT1
- WRITE !!,"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."
- GOTO RX
- D1 DO DEVICE^PSXLBL
- SET ^PSX(553,1,"P")="S"
- STOP ;
- +1 IF ^PSX(553,1,"P")="R"
- SET ^PSX(553,1,"P")="S"
- +2 KILL C,DIC,DIR,X,Y,ZX,BATREF1,OUT,Z1,NODE,TRUG,J,N,ZA2,RXX,RXY,Z,ZEND
- +3 KILL CNT,REPRINT,RESET,BATREF,N514,PSXBAR,PSXLAP,CNT1
- +4 KILL DTOUT,DUOUT,DIRUT,DIROUT,PSXBEG,PSXEND,PSXBLR,R554
- +5 QUIT
- HELP ;
- +1 SET Z=ZA2-1
- SET ZEND=ZA2
- SKIP ;
- +1 FOR
- SET Z=$ORDER(^PSX(552.2,Z))
- if 'Z!(Z>ZEND)
- QUIT
- SET BATREF1=$PIECE(^(Z,0),U)
- DO S1
- if $GET(OUT)
- QUIT
- +2 QUIT
- S1 WRITE @IOF
- +1 WRITE !,"You selected CMOP order # ",BATREF1
- +2 WRITE !,"If this is correct, please choose the last USABLE Rx that printed"
- +3 WRITE !,"from the following list: "
- S2 FOR Z1=0:0
- SET Z1=$ORDER(^PSX(552.2,Z,"T",Z1))
- if 'Z1
- QUIT
- SET NODE=^(Z1,0)
- Begin DoDot:1
- +1 IF $PIECE(NODE,"|")="PID"
- WRITE !!,$TRANSLATE($PIECE(NODE,"|",6),"^",","),?30
- QUIT
- +2 IF $PIECE(NODE,"|")="RX1"
- SET TRUG=$PIECE($PIECE(NODE,"|",15),"^",2)
- QUIT
- +3 IF $PIECE(NODE,"|")="ZX1"
- WRITE !,$PIECE(NODE,"|",2),?15,TRUG
- +4 IF $Y>20
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- SET OUT=1
- WRITE @IOF
- End DoDot:1
- if $GET(OUT)
- QUIT
- +5 QUIT
- PRINT ;
- +1 SET A0=""
- SET AZ1=BATREF_"-"
- SET ^TMP($JOB,PSXBEG)=""
- +2 FOR
- SET A0=$ORDER(^PSX(552.2,"B",A0))
- if ($GET(A0)']"")
- QUIT
- IF A0[AZ1
- Begin DoDot:1
- +3 FOR A1=0:0
- SET A1=$ORDER(^PSX(552.2,"B",A0,A1))
- if 'A1!(A1>PSXEND)
- QUIT
- Begin DoDot:2
- +4 IF A1>PSXBEG
- SET ^TMP($JOB,A1)=""
- +5 KILL AZ
- End DoDot:2
- End DoDot:1
- +6 KILL A1,ZA2,A0,AZ1
- MAIN ;
- +1 FOR A1=0:0
- SET A1=$ORDER(^TMP($JOB,A1))
- if 'A1
- QUIT
- SET ZA2=A1-1
- DO MAIN^PSXLBL1
- F514 DO NOW^%DTC
- SET (Y,RNOW1)=%
- XECUTE ^DD("DD")
- SET RNOW=$PIECE(Y,":",1,2)
- KILL Y,%,DD,DO
- +1 SET DA=ZA2
- +2 IF $GET(REPRINT)
- Begin DoDot:1
- +3 IF '$DATA(^PSX(552.1,N514,3,0))
- SET ^PSX(552.1,N514,3,0)="^552.115^^"
- +4 SET DA(1)=N514
- SET DIC(0)="LMZ"
- SET DIC="^PSX(552.1,DA(1),3,"
- SET X="BATCH REPRINTED by "_$PIECE($GET(^VA(200,DUZ,0)),"^")_" on "_RNOW
- SET DLAYGO=552
- End DoDot:1
- GOTO F1
- +5 IF '$DATA(^PSX(552.1,N514,4,0))
- SET ^PSX(552.1,N514,4,0)="^552.117D^^"
- +6 SET DA(1)=N514
- SET DIC(0)="LMZ"
- SET DIC="^PSX(552.1,DA(1),4,"
- SET X=RNOW1
- SET DIC("DR")="1////"_DUZ
- SET DLAYGO=552
- F1 DO FILE^DICN
- KILL DIC,X,DLAYGO
- F2 IF '$DATA(^PSX(552.2,"AQ",BATREF))
- IF ($PIECE($GET(^PSX(552.1,N514,0)),"^",2)=2)
- Begin DoDot:1
- +1 SET $PIECE(^PSX(552.1,N514,0),"^",2)=3
- SET $PIECE(^(0),"^",6)=RNOW1
- +2 SET DIK="^PSX(552.1,"
- SET DA=N514
- DO IX^DIK
- KILL DIK,DA
- +3 SET $PIECE(^PSX(554,1,0),"^",4)=BATREF
- End DoDot:1
- +4 SET PSXDA=N514
- DO ACK^PSXNOTE
- F553 SET ^PSX(553,1,"P")="S"
- END ;
- +1 KILL ^PSX(552.1,"APR",BATREF)
- +2 KILL NOW,BDAT,BDATE,EDAT,EDATE,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,N2,N3,SITE
- +3 KILL ZA2,ADDR,AZ,AZ1,B,C1,C2,DIE,DR,I,N4,N514,Q1,TODAY,RNOW,RX1,ZX,BAR
- +4 KILL S,SADD1,SADD2,SCITY,ZZT,F,SIGN,SNAME,SSN,SSTATE,STEL,SZIP,TEMP,TODAY
- +5 KILL PSXBAR0,PSXBAR1,R554,DIRUT,DTOUT,DUOUT,DIROUT,RNOW1
- +6 QUIT
- MSG WRITE !!,"Labels may NOT be printed while the CMOP "_$SELECT($GET(ZH)="F":"Background Filer ",1:"Interface ")_"is running.",!!,"Please try again,later.",!!
- LOCK -^PSX(553)
- +1 KILL ZH,R554
- +2 QUIT
- END1 KILL PSXBEG,PSXEND,BATREF,Z,ER,NTE,Q,V,C,ZZ,Z,X,Y,G,A,CT,CH1,L,PSXST,ZY
- +1 KILL IEN14,CNT,R554,PSXBLR
- +2 QUIT