- PSDRPGS1 ;BIR/JPW-Reprint Green Sheet (VA FORM 10-2638) cont'd ; 3 Mar 98
- ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
- ;**Y2K compliance** display 4 digit year on va forms
- START ;loop through transactions
- ;second call to %ZIS to restore varibles for open execute
- I $D(ZTQUEUED) S IOP=ION D ^%ZIS U IO
- S PSD=$P(PSDS,"^",2),PSDCNT=1
- S PSD1="" F S PSD1=$O(PSD1(PSD1)) Q:PSD1="" D LOOP
- END K %ZIS,ANS,ASK,C,CNT,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,LINE,LOT,NAOU,NAOUN,NODE,NODE1
- K OK,ORD,ORDN,POP,PRT,PSD,PSD1,PSDA,PSDBY,PSDBYN,PSDCNT,PSDDT,PSDEV,PSDOUT,PSDCPI,PSDPN,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDTR,PSDTRN,PSDYR,REPRINT,QTY,SITE,STAT,TRANS,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
- D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- Q
- LOOP S PSDPN=$P(PSD1(PSD1),",",PSDCNT),PSDCNT=PSDCNT+1 I PSDPN="" S PSDCNT=1 Q
- S PSDA=$O(^PSD(58.81,"D",PSDPN,0)) D SET
- G LOOP
- Q
- SET ;set data for printing
- K TRANS,PSDTR S PSDOUT=0
- Q:'$D(^PSD(58.81,+PSDA,0)) S NODE=^PSD(58.81,+PSDA,0)
- Q:+$P(NODE,"^",3)'=+PSDS I (+$P(NODE,"^",11)>4)&(+$P(NODE,"^",11)'=10)&(+$P(NODE,U,11)'=13) Q
- I +$P($G(^PSD(58.81,PSDA,"CS")),"^",4) S REPRINT=1
- S PSD=+$P(NODE,"^",18)
- S NAOUN=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S PSDR=$P(NODE,"^",5),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S PSDT=$P(NODE,"^",4)
- S QTY=$P(NODE,"^",6) I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
- S LOT=$P(NODE,"^",14),EXP=$P(NODE,"^",15),EXPD="" I EXP S Y=$E(EXP,1,7) X ^DD("DD") S EXPD=Y
- S (PSDBY,PSDBYN,ORD,ORDN)=""
- I $D(^PSD(58.81,PSDA,1)) S NODE1=^(1),PSDBY=$P(NODE1,"^"),ORD=$P(NODE1,"^",7)
- S:ORD ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S:PSDBY PSDBYN=$S($P($G(^VA(200,PSDBY,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S CNT=1,PSDTR(CNT)=+$O(^PSD(58.81,"AE",PSDA,0)) D:PSDTR(CNT) G:PSDOUT PRINT
- .S TRANS=1
- .D SETT Q:PSDOUT
- .S NAOU=+$P($G(^PSD(58.81,PSDTR(CNT),0)),"^",18)
- .S:NAOU $P(PSDTR(CNT),"^",2)=$S($P($G(^PSD(58.8,+NAOU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- PRINT ;print green sheet
- I ORDN]"",ORDN'="UNKNOWN" S ORDN=$P(ORDN,",")_","_$E($P(ORDN,",",2))
- I PSDBYN]"",PSDBYN'="UNKNOWN" S PSDBYN=$P(PSDBYN,",")_","_$E($P(PSDBYN,",",2))
- S PSDDT="" I PSDT S Y=PSDT X ^DD("DD")
- S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) S PSDDT=$E(PSDT,4,5)_"/"_$E(PSDT,6,7)_"/"_PSDYR
- W:$Y @IOF W:$D(REPRINT) ?10,"** REPRINT **" I '$D(TRANS) W ?33,NAOUN
- W:$D(TRANS) "** Transferred to: ",$S($P(PSDTR(CNT),"^",2)]"":$P(PSDTR(CNT),"^",2),1:$P(PSDTR(CNT-1),"^",2))," **"
- D A7BAR^PSDPGS1 I $D(A7PRT) W @A7BAR1,PSDPN,@A7BAR0 ;DALISC/JRR
- W !!,?56,PSDPN,!!,?6,PSDRN,?36,EXPD,?65,QTY,!!,?6,LOT,?20,ORDN,?42,PSDBYN,?60,$E(NAOUN,1,6),?67,PSDDT,!
- F LINE=1:1:50 W !
- W:ASK !
- W ?6,PSDRN,?61,PSDPN,!
- K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="103////1" D ^DIE K DA,DIE,DR
- Q
- SETT ;set trans naous
- S PSDTRN=+$O(^PSD(58.81,"AE",+PSDTR(CNT),0)) Q:'PSDTRN
- S NAOU=$P($G(^PSD(58.81,+PSDTRN,0)),"^",18) I 'NAOU S PSDOUT=1 Q
- S:NAOU $P(PSDTR(CNT),"^",2)=$S($P($G(^PSD(58.8,+NAOU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- I $O(^PSD(58.81,"AE",+PSDTRN,0)) S CNT=CNT+1,PSDTR(CNT)=$O(^PSD(58.81,"AE",+PSDTRN,0)) G SETT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDRPGS1 3188 printed Feb 18, 2025@23:15:16 Page 2
- PSDRPGS1 ;BIR/JPW-Reprint Green Sheet (VA FORM 10-2638) cont'd ; 3 Mar 98
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
- +2 ;**Y2K compliance** display 4 digit year on va forms
- START ;loop through transactions
- +1 ;second call to %ZIS to restore varibles for open execute
- +2 IF $DATA(ZTQUEUED)
- SET IOP=ION
- DO ^%ZIS
- USE IO
- +3 SET PSD=$PIECE(PSDS,"^",2)
- SET PSDCNT=1
- +4 SET PSD1=""
- FOR
- SET PSD1=$ORDER(PSD1(PSD1))
- if PSD1=""
- QUIT
- DO LOOP
- END KILL %ZIS,ANS,ASK,C,CNT,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,LINE,LOT,NAOU,NAOUN,NODE,NODE1
- +1 KILL OK,ORD,ORDN,POP,PRT,PSD,PSD1,PSDA,PSDBY,PSDBYN,PSDCNT,PSDDT,PSDEV,PSDOUT,PSDCPI,PSDPN,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDTR,PSDTRN,PSDYR,REPRINT,QTY,SITE,STAT,TRANS,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
- +2 DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 QUIT
- LOOP SET PSDPN=$PIECE(PSD1(PSD1),",",PSDCNT)
- SET PSDCNT=PSDCNT+1
- IF PSDPN=""
- SET PSDCNT=1
- QUIT
- +1 SET PSDA=$ORDER(^PSD(58.81,"D",PSDPN,0))
- DO SET
- +2 GOTO LOOP
- +3 QUIT
- SET ;set data for printing
- +1 KILL TRANS,PSDTR
- SET PSDOUT=0
- +2 if '$DATA(^PSD(58.81,+PSDA,0))
- QUIT
- SET NODE=^PSD(58.81,+PSDA,0)
- +3 if +$PIECE(NODE,"^",3)'=+PSDS
- QUIT
- IF (+$PIECE(NODE,"^",11)>4)&(+$PIECE(NODE,"^",11)'=10)&(+$PIECE(NODE,U,11)'=13)
- QUIT
- +4 IF +$PIECE($GET(^PSD(58.81,PSDA,"CS")),"^",4)
- SET REPRINT=1
- +5 SET PSD=+$PIECE(NODE,"^",18)
- +6 SET NAOUN=$SELECT($PIECE($GET(^PSD(58.8,+PSD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +7 SET PSDR=$PIECE(NODE,"^",5)
- SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +8 SET PSDT=$PIECE(NODE,"^",4)
- +9 SET QTY=$PIECE(NODE,"^",6)
- IF $DATA(^PSD(58.81,PSDA,4))
- IF +$PIECE(^(4),"^",3)
- SET QTY=$PIECE(^(4),"^",3)
- +10 SET LOT=$PIECE(NODE,"^",14)
- SET EXP=$PIECE(NODE,"^",15)
- SET EXPD=""
- IF EXP
- SET Y=$EXTRACT(EXP,1,7)
- XECUTE ^DD("DD")
- SET EXPD=Y
- +11 SET (PSDBY,PSDBYN,ORD,ORDN)=""
- +12 IF $DATA(^PSD(58.81,PSDA,1))
- SET NODE1=^(1)
- SET PSDBY=$PIECE(NODE1,"^")
- SET ORD=$PIECE(NODE1,"^",7)
- +13 if ORD
- SET ORDN=$SELECT($PIECE($GET(^VA(200,ORD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +14 if PSDBY
- SET PSDBYN=$SELECT($PIECE($GET(^VA(200,PSDBY,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +15 SET CNT=1
- SET PSDTR(CNT)=+$ORDER(^PSD(58.81,"AE",PSDA,0))
- if PSDTR(CNT)
- Begin DoDot:1
- +16 SET TRANS=1
- +17 DO SETT
- if PSDOUT
- QUIT
- +18 SET NAOU=+$PIECE($GET(^PSD(58.81,PSDTR(CNT),0)),"^",18)
- +19 if NAOU
- SET $PIECE(PSDTR(CNT),"^",2)=$SELECT($PIECE($GET(^PSD(58.8,+NAOU,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- End DoDot:1
- if PSDOUT
- GOTO PRINT
- PRINT ;print green sheet
- +1 IF ORDN]""
- IF ORDN'="UNKNOWN"
- SET ORDN=$PIECE(ORDN,",")_","_$EXTRACT($PIECE(ORDN,",",2))
- +2 IF PSDBYN]""
- IF PSDBYN'="UNKNOWN"
- SET PSDBYN=$PIECE(PSDBYN,",")_","_$EXTRACT($PIECE(PSDBYN,",",2))
- +3 SET PSDDT=""
- IF PSDT
- SET Y=PSDT
- XECUTE ^DD("DD")
- +4 SET PSDYR=$PIECE(Y,",",2)
- SET PSDYR=$EXTRACT(PSDYR,1,4)
- SET PSDDT=$EXTRACT(PSDT,4,5)_"/"_$EXTRACT(PSDT,6,7)_"/"_PSDYR
- +5 if $Y
- WRITE @IOF
- if $DATA(REPRINT)
- WRITE ?10,"** REPRINT **"
- IF '$DATA(TRANS)
- WRITE ?33,NAOUN
- +6 if $DATA(TRANS)
- WRITE "** Transferred to: ",$SELECT($PIECE(PSDTR(CNT),"^",2)]"":$PIECE(PSDTR(CNT),"^",2),1:$PIECE(PSDTR(CNT-1),"^",2))," **"
- +7 ;DALISC/JRR
- DO A7BAR^PSDPGS1
- IF $DATA(A7PRT)
- WRITE @A7BAR1,PSDPN,@A7BAR0
- +8 WRITE !!,?56,PSDPN,!!,?6,PSDRN,?36,EXPD,?65,QTY,!!,?6,LOT,?20,ORDN,?42,PSDBYN,?60,$EXTRACT(NAOUN,1,6),?67,PSDDT,!
- +9 FOR LINE=1:1:50
- WRITE !
- +10 if ASK
- WRITE !
- +11 WRITE ?6,PSDRN,?61,PSDPN,!
- +12 KILL DA,DIE,DR
- SET DA=PSDA
- SET DIE=58.81
- SET DR="103////1"
- DO ^DIE
- KILL DA,DIE,DR
- +13 QUIT
- SETT ;set trans naous
- +1 SET PSDTRN=+$ORDER(^PSD(58.81,"AE",+PSDTR(CNT),0))
- if 'PSDTRN
- QUIT
- +2 SET NAOU=$PIECE($GET(^PSD(58.81,+PSDTRN,0)),"^",18)
- IF 'NAOU
- SET PSDOUT=1
- QUIT
- +3 if NAOU
- SET $PIECE(PSDTR(CNT),"^",2)=$SELECT($PIECE($GET(^PSD(58.8,+NAOU,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +4 IF $ORDER(^PSD(58.81,"AE",+PSDTRN,0))
- SET CNT=CNT+1
- SET PSDTR(CNT)=$ORDER(^PSD(58.81,"AE",+PSDTRN,0))
- GOTO SETT
- +5 QUIT