- PSACON2 ;BIR/LTL-Display Connected Drug and Procurement History - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
- ;This routine is called by PSACON.
- ;
- ;References to $$UNITCODE^PRCPUX1 are covered by IA #259
- ;References to $$VENNAME^PRCPUX1 are covered by IA #259
- ;References to ^PSDRUG( are covered by IA #2095
- ;References to ^PRC( are covered by IA #214
- ;
- Q:'$O(^PRC(441,+PSA(1),4,0))!($G(PSAOUT))
- HIS K PSACON N DIRUT,PSADT,PSAOUT,PSAB,PSAD,PSAQ S (PSA(9),PSAOUT)=0
- I PSA(1) F S PSA(9)=$O(^PRC(441,+PSA(1),4,PSA(9))) Q:'PSA(9) S:$O(^PRC(441,+PSA(1),4,+PSA(9),1,0)) PSA(10)=1
- I $G(PSA(10)) S DIR(0)="Y",DIR("A")="Procurement history exists, would you like to review",DIR("B")="Yes" W ! D ^DIR K DIR D:Y I Y<1 S PSAOUT=1 G END G:$D(DIRUT) END
- .S DIR(0)="D",DIR("A")="How far back in time would you like to go",DIR("B")="T-6M" W ! D ^DIR K DIR Q:$D(DIRUT) S PSA(13)=+Y
- .X ^DD("DD") S PSADT=Y
- .D NOW^%DTC S X1=X,X2=PSA(13) D ^%DTC S PSAD=$S(X/30>0:X/30,1:1)
- .S PSA(9)=$O(^PRC(441,+PSA(1),4,0)),Y=1
- I '$O(^PRC(441,+PSA(1),4,PSA(9))) G DEV
- S DIC="^PRC(441,+PSA(1),4,",DIC(0)="AEMQZ",DIC("W")="W:'$O(^(1,0)) "" NO HISTORY""",DA(1)=PSA(1) W ! D ^DIC K DIC S PSA(9)=+Y I Y<0 S PSAOUT=1 G END
- I '$O(^PRC(441,+PSA(1),4,+PSA(9),1,0)) W !,"Sorry, no history for that particular Control Point.",! G END
- DEV K IO("Q") N %ZIS,IOP,POP S %ZIS="Q",%ZIS("A")="For procurement history, please select DEVICE: " W ! D ^%ZIS I POP W !,"NO DEVICE SELECTED OR OUTPUT PRINTED!" S PSAOUT=1 G END
- I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="LOOP^PSACON2",ZTDESC="Drug Procurement History",ZTSAVE("PSA*")="" D ^%ZTLOAD,HOME^%ZIS S PSAOUT=1 G END
- LOOP N PSALN,PSAPG,PSARPDT S (PSAPG,PSA(11))=0,Y=1 D HEADER
- F S PSA(11)=$O(^PRC(441,+PSA(1),4,+PSA(9),1,PSA(11))),PSA(14)=$P($G(^PRC(442,+PSA(11),1)),U,15) Q:'PSA(11)!(PSAOUT) D:$Y+4>IOSL HEADER G:'Y END D:PSA(14)'<PSA(13)
- .W !,$E($P($G(^PRC(442,+PSA(11),0)),U),5,10)
- .W ?8,$E($$VENNAME^PRCPUX1($P($G(^PRC(442,+PSA(11),1)),U)_"PRC(440"),1,20)
- .S Y=PSA(14) X ^DD("DD") W ?32,Y
- .S PSA(12)=$O(^PRC(442,+PSA(11),2,"AE",+PSA(1),""))
- .W ?45,$J($P($G(^PRC(442,+PSA(11),2,+PSA(12),0)),U,2),3) S PSAQ=$G(PSAQ)+$P($G(^(0)),U,2)
- .W " ",$$UNITCODE^PRCPUX1($P($G(^PRC(442,+PSA(11),2,+PSA(12),0)),U,3))
- .W ?55,"$",$J($P($G(^PRC(442,+PSA(11),2,+PSA(12),2)),U),9,2) S PSAB=$G(PSAB)+$P($G(^(2)),U)
- .W ?70,$P($G(^PRC(442,+PSA(11),2,+PSA(12),2)),U,8),! S Y=1
- .I '$O(^PRC(441,+PSA(1),4,+PSA(9),1,PSA(11))) S X=$G(PSAQ)/PSAD,X2=1,X3=5 D COMMA^%DTC W PSALN,!!,"Average ordered/month: ",X,?34,"TOTAL ORD: ",$J($G(PSAQ),3),?50,"TOTAL $: " S X=PSAB,X2="0$",X3=5 D COMMA^%DTC W X
- END W:$E(IOST)'="C" @IOF
- I $E(IOST,1,2)="C-",'PSAOUT S DIR(0)="EA",DIR("A")="END OF HISTORY! Press <RET> to return to the option." W ! D ^DIR K DIR
- D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
- K PSA,PSACON
- Q
- I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSAOUT=1 Q
- W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1 W !,$E($P($G(^PSDRUG(+PSA,0)),U),1,40)
- W "=> from ",$G(PSADT),?60,"PAGE: ",PSAPG,!,PSALN,!,"PO #",?10,"VENDOR",?33,"PO DATE",?45,"QTY ORD",?57,"COST",?70,"QTY RECD",!,PSALN,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSACON2 3337 printed Jan 18, 2025@02:50:16 Page 2
- PSACON2 ;BIR/LTL-Display Connected Drug and Procurement History - CONT'D ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
- +2 ;This routine is called by PSACON.
- +3 ;
- +4 ;References to $$UNITCODE^PRCPUX1 are covered by IA #259
- +5 ;References to $$VENNAME^PRCPUX1 are covered by IA #259
- +6 ;References to ^PSDRUG( are covered by IA #2095
- +7 ;References to ^PRC( are covered by IA #214
- +8 ;
- +9 if '$ORDER(^PRC(441,+PSA(1),4,0))!($GET(PSAOUT))
- QUIT
- HIS KILL PSACON
- NEW DIRUT,PSADT,PSAOUT,PSAB,PSAD,PSAQ
- SET (PSA(9),PSAOUT)=0
- +1 IF PSA(1)
- FOR
- SET PSA(9)=$ORDER(^PRC(441,+PSA(1),4,PSA(9)))
- if 'PSA(9)
- QUIT
- if $ORDER(^PRC(441,+PSA(1),4,+PSA(9),1,0))
- SET PSA(10)=1
- +2 IF $GET(PSA(10))
- SET DIR(0)="Y"
- SET DIR("A")="Procurement history exists, would you like to review"
- SET DIR("B")="Yes"
- WRITE !
- DO ^DIR
- KILL DIR
- if Y
- Begin DoDot:1
- +3 SET DIR(0)="D"
- SET DIR("A")="How far back in time would you like to go"
- SET DIR("B")="T-6M"
- WRITE !
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- SET PSA(13)=+Y
- +4 XECUTE ^DD("DD")
- SET PSADT=Y
- +5 DO NOW^%DTC
- SET X1=X
- SET X2=PSA(13)
- DO ^%DTC
- SET PSAD=$SELECT(X/30>0:X/30,1:1)
- +6 SET PSA(9)=$ORDER(^PRC(441,+PSA(1),4,0))
- SET Y=1
- End DoDot:1
- IF Y<1
- SET PSAOUT=1
- GOTO END
- if $DATA(DIRUT)
- GOTO END
- +7 IF '$ORDER(^PRC(441,+PSA(1),4,PSA(9)))
- GOTO DEV
- +8 SET DIC="^PRC(441,+PSA(1),4,"
- SET DIC(0)="AEMQZ"
- SET DIC("W")="W:'$O(^(1,0)) "" NO HISTORY"""
- SET DA(1)=PSA(1)
- WRITE !
- DO ^DIC
- KILL DIC
- SET PSA(9)=+Y
- IF Y<0
- SET PSAOUT=1
- GOTO END
- +9 IF '$ORDER(^PRC(441,+PSA(1),4,+PSA(9),1,0))
- WRITE !,"Sorry, no history for that particular Control Point.",!
- GOTO END
- DEV KILL IO("Q")
- NEW %ZIS,IOP,POP
- SET %ZIS="Q"
- SET %ZIS("A")="For procurement history, please select DEVICE: "
- WRITE !
- DO ^%ZIS
- IF POP
- WRITE !,"NO DEVICE SELECTED OR OUTPUT PRINTED!"
- SET PSAOUT=1
- GOTO END
- +1 IF $DATA(IO("Q"))
- NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
- SET ZTRTN="LOOP^PSACON2"
- SET ZTDESC="Drug Procurement History"
- SET ZTSAVE("PSA*")=""
- DO ^%ZTLOAD
- DO HOME^%ZIS
- SET PSAOUT=1
- GOTO END
- LOOP NEW PSALN,PSAPG,PSARPDT
- SET (PSAPG,PSA(11))=0
- SET Y=1
- DO HEADER
- +1 FOR
- SET PSA(11)=$ORDER(^PRC(441,+PSA(1),4,+PSA(9),1,PSA(11)))
- SET PSA(14)=$PIECE($GET(^PRC(442,+PSA(11),1)),U,15)
- if 'PSA(11)!(PSAOUT)
- QUIT
- if $Y+4>IOSL
- DO HEADER
- if 'Y
- GOTO END
- if PSA(14)'<PSA(13)
- Begin DoDot:1
- +2 WRITE !,$EXTRACT($PIECE($GET(^PRC(442,+PSA(11),0)),U),5,10)
- +3 WRITE ?8,$EXTRACT($$VENNAME^PRCPUX1($PIECE($GET(^PRC(442,+PSA(11),1)),U)_"PRC(440"),1,20)
- +4 SET Y=PSA(14)
- XECUTE ^DD("DD")
- WRITE ?32,Y
- +5 SET PSA(12)=$ORDER(^PRC(442,+PSA(11),2,"AE",+PSA(1),""))
- +6 WRITE ?45,$JUSTIFY($PIECE($GET(^PRC(442,+PSA(11),2,+PSA(12),0)),U,2),3)
- SET PSAQ=$GET(PSAQ)+$PIECE($GET(^(0)),U,2)
- +7 WRITE " ",$$UNITCODE^PRCPUX1($PIECE($GET(^PRC(442,+PSA(11),2,+PSA(12),0)),U,3))
- +8 WRITE ?55,"$",$JUSTIFY($PIECE($GET(^PRC(442,+PSA(11),2,+PSA(12),2)),U),9,2)
- SET PSAB=$GET(PSAB)+$PIECE($GET(^(2)),U)
- +9 WRITE ?70,$PIECE($GET(^PRC(442,+PSA(11),2,+PSA(12),2)),U,8),!
- SET Y=1
- +10 IF '$ORDER(^PRC(441,+PSA(1),4,+PSA(9),1,PSA(11)))
- SET X=$GET(PSAQ)/PSAD
- SET X2=1
- SET X3=5
- DO COMMA^%DTC
- WRITE PSALN,!!,"Average ordered/month: ",X,?34,"TOTAL ORD: ",$JUSTIFY($GET(PSAQ),3),?50,"TOTAL $: "
- SET X=PSAB
- SET X2="0$"
- SET X3=5
- DO COMMA^%DTC
- WRITE X
- End DoDot:1
- END if $EXTRACT(IOST)'="C"
- WRITE @IOF
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF 'PSAOUT
- SET DIR(0)="EA"
- SET DIR("A")="END OF HISTORY! Press <RET> to return to the option."
- WRITE !
- DO ^DIR
- KILL DIR
- +2 DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL IO("Q")
- +3 KILL PSA,PSACON
- +4 QUIT
- IF PSAPG
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET PSAOUT=1
- QUIT
- +1 IF $$S^%ZTLOAD
- WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U),"."
- SET PSAOUT=1
- QUIT
- +2 if $Y
- WRITE @IOF
- SET $PIECE(PSALN,"-",81)=""
- SET PSAPG=PSAPG+1
- WRITE !,$EXTRACT($PIECE($GET(^PSDRUG(+PSA,0)),U),1,40)
- +3 WRITE "=> from ",$GET(PSADT),?60,"PAGE: ",PSAPG,!,PSALN,!,"PO #",?10,"VENDOR",?33,"PO DATE",?45,"QTY ORD",?57,"COST",?70,"QTY RECD",!,PSALN,!
- +4 QUIT