- PSIVST2 ;BIR/PR-COMP IV STATS FILE ;16 DEC 97 / 1:40 PM
- ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
- ENCT ;Need DFN, PSIVS, ON, PSIVNOL,W42, PSIVC AND PSIVD
- Q:'$D(^PS(55,DFN,"IV",ON)) S X=^PS(55,DFN,"IV",ON,0),P16=$P(X,U,6),P4=$P(X,U,4),IV=PSIVS,PNL=PSIVNOL
- ;
- DATE ;Set up date node.
- S $P(^PS(50.8,IV,2,0),U,1,3)="^50.803D^"_PSIVD S:'$D(^(PSIVD,0)) ^(0)=PSIVD,$P(^(0),U,4)=$P(^PS(50.8,IV,2,0),U,4)+1
- ;
- W1 ;Set up ward dispensed node.
- I 'W42 S W42=$S($D(^DPT(DFN,.1)):$O(^DIC(42,"B",$P(^(.1),U),0)),1:.5)
- S $P(^PS(50.8,IV,2,PSIVD,1,0),U,1,3)="^50.804P^"_W42 S:'$D(^(W42,0)) ^(0)=W42,$P(^(0),U,4)=$P(^PS(50.8,IV,2,PSIVD,1,0),U,4)+1 S WPC=$S(P4="P":2,P4="A":3,P4="H":4,P4="C":5,1:6)
- I PSIVC=1 S $P(^(0),U,WPC)=$P(^PS(50.8,IV,2,PSIVD,1,W42,0),U,WPC)+PNL G DRUG
- ;
- W2 ;Set up ward destroyed,recycled,cancelled node.
- S NODE=$S(PSIVC=2:"R",PSIVC=3:"D",1:"C") S:'$D(^PS(50.8,IV,2,PSIVD,1,W42,NODE)) ^(NODE)=W42 S $P(^(NODE),U,WPC)=$P(^(NODE),U,WPC)+PNL
- ;
- DRUG ;Get the order drugs.
- F FI=52.6,52.7 F I=0:0 S I=$O(^PS(55,DFN,"IV",ON,$S(FI[6:"AD",1:"SOL"),I)) Q:'I S PDR=^(I,0) D CT
- K W42,P4,P16,FI,PDR,A,PIECE,PCE,NODE,WPC Q
- ;
- CT ;Set up 0 node, get drug node if not already there.
- S:'$D(^PS(50.8,IV,2,PSIVD,2,0)) ^(0)="^50.805" S DA=$O(^PS(50.8,IV,2,PSIVD,2,"AC",FI,+PDR,0)) G:DA OV F DA=$P(^PS(50.8,IV,2,PSIVD,2,0),U,3)+1:1 Q:'$D(^(DA,0))
- S $P(^PS(50.8,IV,2,PSIVD,2,0),U,3,4)=DA_"^"_DA
- ;
- OV ;Update or set drug node.
- S X=^PS(FI,+PDR,0),$P(^PS(50.8,IV,2,PSIVD,2,DA,0),U)=$P(X,U)_$S(FI=52.7:" "_$P(X,U,3)_$S($P(X,U,4)]"":" "_$P(X,U,4),1:""),1:""),Y=^(0),DPC=$S(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:12)
- S $P(Y,U,DPC)=PNL*$P(PDR,U,2)+$P(Y,U,DPC),$P(Y,U,5,11)=$P(X,U,7)_U_$S(FI=52.7:1,1:$P(X,U,3))_U_FI_"^"_($P(Y,U,8)+$S(PSIVC=1:PNL,1:0))_U_($P(Y,U,9)+$S(PSIVC=2:PNL,1:0))_U_($P(Y,U,10)+$S(PSIVC=3:PNL,1:0))_U_($P(Y,U,11)+$S(PSIVC=4:PNL,1:0))
- S ^PS(50.8,IV,2,PSIVD,2,DA,0)=Y
- S ^PS(50.8,IV,2,PSIVD,2,"AC",FI,+PDR,DA)="",^PS(50.8,IV,2,PSIVD,2,"B",$P(X,U,1),$P(X,U,2),DA)=$P(^PSDRUG($P(X,U,2),0),U,9)
- ;
- SUB3 ;Set up the patient,provider,and ward subfiles of the drug.
- F PSIV=1,2,3 S X=$S(PSIV=1:DFN,PSIV=2:P16,1:W42) D CT1
- K DA Q
- CT1 ;
- S $P(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,0),U,1,3)="^50.80"_(5+PSIV)_"^"_X S:'$D(^(X,0)) ^(0)=X,$P(^(0),U,4)=$P(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,0),U,4)+1 D:PSIV=3 WARD
- I PSIV=1 S PCE=$S(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:6)
- I PSIV=2 S PCE=$S(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:5)
- S $P(^(0),U,PCE)=PNL*$P(PDR,U,2)+$P(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,0),U,PCE) I PSIV=1 S $P(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,0),U,5)=W42
- Q
- WARD S:'$D(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,0)) ^(0)="^50.809"
- S:'$D(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,"B",P4)) (A,Z)=$P(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,0),U,3)+1,$P(^(0),U,3,4)=Z_"^"_X,^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,"B",P4,Z)=""
- S A=$O(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,"B",P4,0)) S LO=$S($D(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,A,0)):^(0),1:"")
- S PIECE=$S(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:5)
- S $P(LO,U)=P4,$P(LO,U,PIECE)=(PNL*$P(PDR,U,2)+$P(LO,U,PIECE)),PIECE=$S(PSIVC=1:8,PSIVC=2:9,PSIVC=3:10,1:11),$P(LO,U,PIECE)=$P(LO,U,PIECE)+PNL,^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,A,0)=LO Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVST2 3170 printed Feb 18, 2025@23:31:29 Page 2
- PSIVST2 ;BIR/PR-COMP IV STATS FILE ;16 DEC 97 / 1:40 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
- ENCT ;Need DFN, PSIVS, ON, PSIVNOL,W42, PSIVC AND PSIVD
- +1 if '$DATA(^PS(55,DFN,"IV",ON))
- QUIT
- SET X=^PS(55,DFN,"IV",ON,0)
- SET P16=$PIECE(X,U,6)
- SET P4=$PIECE(X,U,4)
- SET IV=PSIVS
- SET PNL=PSIVNOL
- +2 ;
- DATE ;Set up date node.
- +1 SET $PIECE(^PS(50.8,IV,2,0),U,1,3)="^50.803D^"_PSIVD
- if '$DATA(^(PSIVD,0))
- SET ^(0)=PSIVD
- SET $PIECE(^(0),U,4)=$PIECE(^PS(50.8,IV,2,0),U,4)+1
- +2 ;
- W1 ;Set up ward dispensed node.
- +1 IF 'W42
- SET W42=$SELECT($DATA(^DPT(DFN,.1)):$ORDER(^DIC(42,"B",$PIECE(^(.1),U),0)),1:.5)
- +2 SET $PIECE(^PS(50.8,IV,2,PSIVD,1,0),U,1,3)="^50.804P^"_W42
- if '$DATA(^(W42,0))
- SET ^(0)=W42
- SET $PIECE(^(0),U,4)=$PIECE(^PS(50.8,IV,2,PSIVD,1,0),U,4)+1
- SET WPC=$SELECT(P4="P":2,P4="A":3,P4="H":4,P4="C":5,1:6)
- +3 IF PSIVC=1
- SET $PIECE(^(0),U,WPC)=$PIECE(^PS(50.8,IV,2,PSIVD,1,W42,0),U,WPC)+PNL
- GOTO DRUG
- +4 ;
- W2 ;Set up ward destroyed,recycled,cancelled node.
- +1 SET NODE=$SELECT(PSIVC=2:"R",PSIVC=3:"D",1:"C")
- if '$DATA(^PS(50.8,IV,2,PSIVD,1,W42,NODE))
- SET ^(NODE)=W42
- SET $PIECE(^(NODE),U,WPC)=$PIECE(^(NODE),U,WPC)+PNL
- +2 ;
- DRUG ;Get the order drugs.
- +1 FOR FI=52.6,52.7
- FOR I=0:0
- SET I=$ORDER(^PS(55,DFN,"IV",ON,$SELECT(FI[6:"AD",1:"SOL"),I))
- if 'I
- QUIT
- SET PDR=^(I,0)
- DO CT
- +2 KILL W42,P4,P16,FI,PDR,A,PIECE,PCE,NODE,WPC
- QUIT
- +3 ;
- CT ;Set up 0 node, get drug node if not already there.
- +1 if '$DATA(^PS(50.8,IV,2,PSIVD,2,0))
- SET ^(0)="^50.805"
- SET DA=$ORDER(^PS(50.8,IV,2,PSIVD,2,"AC",FI,+PDR,0))
- if DA
- GOTO OV
- FOR DA=$PIECE(^PS(50.8,IV,2,PSIVD,2,0),U,3)+1:1
- if '$DATA(^(DA,0))
- QUIT
- +2 SET $PIECE(^PS(50.8,IV,2,PSIVD,2,0),U,3,4)=DA_"^"_DA
- +3 ;
- OV ;Update or set drug node.
- +1 SET X=^PS(FI,+PDR,0)
- SET $PIECE(^PS(50.8,IV,2,PSIVD,2,DA,0),U)=$PIECE(X,U)_$SELECT(FI=52.7:" "_$PIECE(X,U,3)_$SELECT($PIECE(X,U,4)]"":" "_$PIECE(X,U,4),1:""),1:"")
- SET Y=^(0)
- SET DPC=$SELECT(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:12)
- +2 SET $PIECE(Y,U,DPC)=PNL*$PIECE(PDR,U,2)+$PIECE(Y,U,DPC)
- SET $PIECE(Y,U,5,11)=$PIECE(X,U,7)_U_$SELECT(FI=52.7:1,1:$PIECE(X,U,3))_U_FI_"^"_($PIECE(Y,U,8)+$SELECT(PSIVC=1:PNL,1:0))_U_($PIECE(Y,U,9)+$SELECT(PSIVC=2:PNL,1:0))_U_($PIECE(Y,U,10)+$SELECT(PSIVC=3:PNL,1:0))_U_($PIECE(Y,U,11)+$SELECT(PSIVC=4:P
- NL,1:0))
- +3 SET ^PS(50.8,IV,2,PSIVD,2,DA,0)=Y
- +4 SET ^PS(50.8,IV,2,PSIVD,2,"AC",FI,+PDR,DA)=""
- SET ^PS(50.8,IV,2,PSIVD,2,"B",$PIECE(X,U,1),$PIECE(X,U,2),DA)=$PIECE(^PSDRUG($PIECE(X,U,2),0),U,9)
- +5 ;
- SUB3 ;Set up the patient,provider,and ward subfiles of the drug.
- +1 FOR PSIV=1,2,3
- SET X=$SELECT(PSIV=1:DFN,PSIV=2:P16,1:W42)
- DO CT1
- +2 KILL DA
- QUIT
- CT1 ;
- +1 SET $PIECE(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,0),U,1,3)="^50.80"_(5+PSIV)_"^"_X
- if '$DATA(^(X,0))
- SET ^(0)=X
- SET $PIECE(^(0),U,4)=$PIECE(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,0),U,4)+1
- if PSIV=3
- DO WARD
- +2 IF PSIV=1
- SET PCE=$SELECT(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:6)
- +3 IF PSIV=2
- SET PCE=$SELECT(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:5)
- +4 SET $PIECE(^(0),U,PCE)=PNL*$PIECE(PDR,U,2)+$PIECE(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,0),U,PCE)
- IF PSIV=1
- SET $PIECE(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,0),U,5)=W42
- +5 QUIT
- WARD if '$DATA(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,0))
- SET ^(0)="^50.809"
- +1 if '$DATA(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,"B",P4))
- SET (A,Z)=$PIECE(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,0),U,3)+1
- SET $PIECE(^(0),U,3,4)=Z_"^"_X
- SET ^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,"B",P4,Z)=""
- +2 SET A=$ORDER(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,"B",P4,0))
- SET LO=$SELECT($DATA(^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,A,0)):^(0),1:"")
- +3 SET PIECE=$SELECT(PSIVC=1:2,PSIVC=2:3,PSIVC=3:4,1:5)
- +4 SET $PIECE(LO,U)=P4
- SET $PIECE(LO,U,PIECE)=(PNL*$PIECE(PDR,U,2)+$PIECE(LO,U,PIECE))
- SET PIECE=$SELECT(PSIVC=1:8,PSIVC=2:9,PSIVC=3:10,1:11)
- SET $PIECE(LO,U,PIECE)=$PIECE(LO,U,PIECE)+PNL
- SET ^PS(50.8,IV,2,PSIVD,2,DA,PSIV,X,1,A,0)=LO
- QUIT