- PSDPSTK1 ;BIR/JPW-Print Data for CS Drugs (cont'd) ; 2 Aug 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- PRINT ;print data for stock drugs
- K LN S (PG,PSDOUT)=0,$P(LN,"-",132)="",%DT="",X="T" D ^%DT X ^DD("DD") S RPDT=Y D HEADER Q:PSDOUT
- I '$D(^TMP("PSDPSTK",$J)) W !!,?45,"***** NO DATA AVAILABLE FOR THIS REPORT *****" G END
- S DRUG="" F S DRUG=$O(^TMP("PSDPSTK",$J,DRUG)) Q:DRUG=""!(PSDOUT) D:$Y+5>IOSL HEADER Q:PSDOUT W !,"=> ",$S(DRUG["ZZ/":"#"_$P(DRUG,"/",2)_" NAME MISSING",1:DRUG) D Q:PSDOUT
- .F NAOU=0:0 S NAOU=$O(^TMP("PSDPSTK",$J,DRUG,NAOU)) Q:'NAOU!(PSDOUT) D Q:PSDOUT
- ..S NODE=^TMP("PSDPSTK",$J,DRUG,NAOU,0) S NAOUN=$S($P(^PSD(58.8,NAOU,0),"^")]"":$P(^(0),"^"),1:"NAOU #"_NAOU_"/NAME MISSING")
- ..I $P(NODE,"^")="I" S Y=$P(NODE,"^",2) X ^DD("DD") S DATEI=Y D:$Y+5>IOSL HEADER Q:PSDOUT W !,?4,NAOUN_" (NAOU INACTIVE AS OF "_DATEI_")",! Q
- ..S LOC=$P(NODE,"^"),STK=$P(NODE,"^",2),TYPE=$P(NODE,"^",3)
- ..S WARD=$G(^TMP("PSDPSTK",$J,DRUG,NAOU,1))
- ..S CNTW=$L(WARD,";;"),CNTT=$L(TYPE,";;"),CNT=$S(CNTT>CNTW!(CNTT=CNTW):CNTT,CNTW>CNTT:CNTW,1:2)
- ..I $Y+5>IOSL D HEADER Q:PSDOUT W !,"=> ",$S(DRUG["ZZ/":"#"_$P(DRUG,"/",2)_" NAME MISSING",1:DRUG)
- ..W !,?4,NAOUN,?45,LOC,?55,$J(STK,6),?67 S WARDN=$P(WARD,";;",2) D:WARDN WARD W WARDN,?101 S TYPEN=$P(TYPE,";;",2) D:TYPEN TYPE W TYPEN,!
- ..I CNT>2 F JJ=3:1:CNT D:$Y+5>IOSL HEADER W ?67 S WARDN=$P(WARD,";;",JJ) D:WARDN WARD W WARDN,?101 S TYPEN=$P(TYPE,";;",JJ) D:TYPEN TYPE W TYPEN,!
- DONE I $E(IOST)'="C" W @IOF
- I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR
- END ;
- K %DT,%ZIS,CNT,CNTT,CNTW,DA,DATEI,DIK,DIR,DIRUT,DRUG,DRUGN,JJ,LN,LOC,NAOU,NAOUN,NODE,PG,POP,PSDIO,PSDT,PSDOUT,RPDT,STK,TYP,TYPE,TYPEN,WARD,WARDN,WRD
- K X,Y,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN,^TMP("PSDPSTK",$J) D ^%ZISC
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
- W:$Y @IOF S PG=PG+1 W !,RPDT,?122,"PAGE: "_PG,!,?55,"DATA FOR CS STOCK DRUGS",!!,"=> DRUG",!,?57,"STOCK",!,?14,"NAOU",?45,"LOCATION",?57,"LEVEL",?67,"WARD (FOR DRUG)",?101,"TYPE",!,LN,!
- Q
- WARD ;checks for vaild ward name
- I $D(^DIC(42,WARDN,0)),$P(^(0),"^")]"" S WARDN=$P(^(0),"^") Q
- S WARDN="WARD #"_WARD_"/NO NAME OR DELETED"
- Q
- TYPE ;ckecks for valid type name
- I $D(^PSI(58.16,TYPEN,0)),$P(^(0),"^")]"" S TYPEN=$P(^(0),"^") Q
- S TYPEN="TYPE #"_TYPEN_"/NO NAME OR DELETED"
- Q
- PSDPSTK1 ;BIR/JPW-Print Data for CS Drugs (cont'd) ; 2 Aug 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- PRINT ;print data for stock drugs
- +1 KILL LN
- SET (PG,PSDOUT)=0
- SET $PIECE(LN,"-",132)=""
- SET %DT=""
- SET X="T"
- DO ^%DT
- XECUTE ^DD("DD")
- SET RPDT=Y
- DO HEADER
- IF PSDOUT
- QUIT
- +2 IF '$DATA(^TMP("PSDPSTK",$JOB))
- WRITE !!,?45,"***** NO DATA AVAILABLE FOR THIS REPORT *****"
- GOTO END
- +3 SET DRUG=""
- FOR
- SET DRUG=$ORDER(^TMP("PSDPSTK",$JOB,DRUG))
- IF DRUG=""!(PSDOUT)
- QUIT
- IF $Y+5>IOSL
- DO HEADER
- IF PSDOUT
- QUIT
- WRITE !,"=> ",$SELECT(DRUG["ZZ/":"#"_$PIECE(DRUG,"/",2)_" NAME MISSING",1:DRUG)
- Begin DoDot:1
- +4 FOR NAOU=0:0
- SET NAOU=$ORDER(^TMP("PSDPSTK",$JOB,DRUG,NAOU))
- IF 'NAOU!(PSDOUT)
- QUIT
- Begin DoDot:2
- +5 SET NODE=^TMP("PSDPSTK",$JOB,DRUG,NAOU,0)
- SET NAOUN=$SELECT($PIECE(^PSD(58.8,NAOU,0),"^")]"":$PIECE(^(0),"^"),1:"NAOU #"_NAOU_"/NAME MISSING")
- +6 IF $PIECE(NODE,"^")="I"
- SET Y=$PIECE(NODE,"^",2)
- XECUTE ^DD("DD")
- SET DATEI=Y
- IF $Y+5>IOSL
- DO HEADER
- IF PSDOUT
- QUIT
- WRITE !,?4,NAOUN_" (NAOU INACTIVE AS OF "_DATEI_")",!
- QUIT
- +7 SET LOC=$PIECE(NODE,"^")
- SET STK=$PIECE(NODE,"^",2)
- SET TYPE=$PIECE(NODE,"^",3)
- +8 SET WARD=$GET(^TMP("PSDPSTK",$JOB,DRUG,NAOU,1))
- +9 SET CNTW=$LENGTH(WARD,";;")
- SET CNTT=$LENGTH(TYPE,";;")
- SET CNT=$SELECT(CNTT>CNTW!(CNTT=CNTW):CNTT,CNTW>CNTT:CNTW,1:2)
- +10 IF $Y+5>IOSL
- DO HEADER
- IF PSDOUT
- QUIT
- WRITE !,"=> ",$SELECT(DRUG["ZZ/":"#"_$PIECE(DRUG,"/",2)_" NAME MISSING",1:DRUG)
- +11 WRITE !,?4,NAOUN,?45,LOC,?55,$JUSTIFY(STK,6),?67
- SET WARDN=$PIECE(WARD,";;",2)
- IF WARDN
- DO WARD
- WRITE WARDN,?101
- SET TYPEN=$PIECE(TYPE,";;",2)
- IF TYPEN
- DO TYPE
- WRITE TYPEN,!
- +12 IF CNT>2
- FOR JJ=3:1:CNT
- IF $Y+5>IOSL
- DO HEADER
- WRITE ?67
- SET WARDN=$PIECE(WARD,";;",JJ)
- IF WARDN
- DO WARD
- WRITE WARDN,?101
- SET TYPEN=$PIECE(TYPE,";;",JJ)
- IF TYPEN
- DO TYPE
- WRITE TYPEN,!
- End DoDot:2
- IF PSDOUT
- QUIT
- End DoDot:1
- IF PSDOUT
- QUIT
- DONE IF $EXTRACT(IOST)'="C"
- WRITE @IOF
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF 'PSDOUT
- WRITE !
- KILL DIR,DIRUT
- SET DIR(0)="EA"
- SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
- DO ^DIR
- KILL DIR
- END ;
- +1 KILL %DT,%ZIS,CNT,CNTT,CNTW,DA,DATEI,DIK,DIR,DIRUT,DRUG,DRUGN,JJ,LN,LOC,NAOU,NAOUN,NODE,PG,POP,PSDIO,PSDT,PSDOUT,RPDT,STK,TYP,TYPE,TYPEN,WARD,WARDN,WRD
- +2 KILL X,Y,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN,^TMP("PSDPSTK",$JOB)
- DO ^%ZISC
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF PG
- WRITE !
- KILL DA,DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET PSDOUT=1
- QUIT
- +2 IF $Y
- WRITE @IOF
- SET PG=PG+1
- WRITE !,RPDT,?122,"PAGE: "_PG,!,?55,"DATA FOR CS STOCK DRUGS",!!,"=> DRUG",!,?57,"STOCK",!,?14,"NAOU",?45,"LOCATION",?57,"LEVEL",?67,"WARD (FOR DRUG)",?101,"TYPE",!,LN,!
- +3 QUIT
- WARD ;checks for vaild ward name
- +1 IF $DATA(^DIC(42,WARDN,0))
- IF $PIECE(^(0),"^")]""
- SET WARDN=$PIECE(^(0),"^")
- QUIT
- +2 SET WARDN="WARD #"_WARD_"/NO NAME OR DELETED"
- +3 QUIT
- TYPE ;ckecks for valid type name
- +1 IF $DATA(^PSI(58.16,TYPEN,0))
- IF $PIECE(^(0),"^")]""
- SET TYPEN=$PIECE(^(0),"^")
- QUIT
- +2 SET TYPEN="TYPE #"_TYPEN_"/NO NAME OR DELETED"
- +3 QUIT
