PSGWCAD ;BHAM ISC/PTD,CML-Calculate and Store AMIS Data ; 29 Dec 93 / 9:13 AM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
;Calling routine passes these variables: PSGWADT -AMIS Date, PSGWDN -drug number, PSGWQD -quantity dispensed, PSGWCAT -AMIS category, PSGWAOU -AOU for returns, SITE -for INPATIENT SITE for AOU.
;IF COMPLETE DATA IS NOT AVAILABLE, SET MISSING DATA FLAG. DO RECALC.
CHKDTA S INC=0 I PSGWCAT="R" I '$D(^PSI(58.1,PSGWAOU,0)) W !!,"Data missing - contact ADP personnel.",!,"The zero node for this AOU is missing.",!!,"No AMIS update made for this return!" G END
I PSGWCAT="R" S LOC3=^PSI(58.1,PSGWAOU,0),PSGWCAT=PSGWCAT_$S($P(LOC3,"^",2)="W":"W",1:"A")
I $D(^PSDRUG(PSGWDN,660)) S LOC1=^(660)
E S INC=1 D RECALC G END
I $D(^PSDRUG(PSGWDN,"PSG")) S LOC2=^("PSG")
E S INC=1 D RECALC G END
F J=3,5,6 I $P(LOC1,"^",J)="" S INC=1 D RECALC G END
F J=2,3 I $P(LOC2,"^",J)="" S INC=1 D RECALC G END
;
MAIN D CALC I PSGWCAT["R" D SETRET,RECALC G END
D SETDSP,RECALC
END K INC,LOC1,LOC2,LOC3,J,DOSE,COST,FLD,CAT,DTDA,DRGDA,FLDA,DA,DR,GOTIT S PSGWCAT=$E(PSGWCAT)
Q
;
CALC ;COMPLETE DATA IS AVAILABLE, SO CALCULATE AMIS DATA.
S DOSE=PSGWQD*$P(LOC2,"^",3),COST=PSGWQD*$P(LOC1,"^",6)
I PSGWCAT="A" S FLD=$S($P(LOC2,"^",2)=0:"04",$P(LOC2,"^",2)=1:"07",$P(LOC2,"^",2)=2:"17",1:"22")
I PSGWCAT="W" S FLD=$S($P(LOC2,"^",2)=0:"03",$P(LOC2,"^",2)=1:"06",$P(LOC2,"^",2)=2:"17",1:"22")
I PSGWCAT["R" S FLD=$S($P(LOC3,"^",2)="W":$S($P(LOC2,"^",2)=0:"03",$P(LOC2,"^",2)=1:"06",$P(LOC2,"^",2)=2:"17",1:"22"),1:$S($P(LOC2,"^",2)=0:"04",$P(LOC2,"^",2)=1:"07",$P(LOC2,"^",2)=2:"17",1:"22"))
Q
;
SETDSP ;
D NEW S:'$D(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",0)) ^(0)="^58.51S^^"
I '$D(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD)) S DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""AMIS"",",DIC(0)="LM",X=FLD,DA(2)=PSGWADT,DA(1)=SITE,DIC("DR")="1///"_DOSE_";2///"_COST K DD,DO D FILE^DICN K DIC Q
S FLDA=$O(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD,0)),$P(^(0),"^",2)=$P(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",FLDA,0),"^",2)+DOSE,$P(^(0),"^",3)=$P(^(0),"^",3)+COST
Q
RECALC ;
D NEW S:'$D(^PSI(58.5,PSGWADT,"S",SITE,"DRG",0)) ^(0)="^58.52P^^"
I '$D(^PSI(58.5,"D",PSGWDN,PSGWADT,SITE)) S DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""DRG"",",DIC(0)="LM",X=PSGWDN,DA(2)=PSGWADT,DA(1)=SITE,DIC("DR")="2///"_INC K DD,DO D FILE^DICN K DIC
S DRGDA=$O(^PSI(58.5,"D",PSGWDN,PSGWADT,SITE,0)) I '$D(^PSI(58.5,PSGWADT,"S",SITE,"DRG",DRGDA,"CAT",0)) S ^(0)="^58.53SA^^"
S GOTIT=0 F CAT=0:0 S CAT=$O(^PSI(58.5,PSGWADT,"S",SITE,"DRG",DRGDA,"CAT",CAT)) Q:'CAT I $P(^(CAT,0),"^")=PSGWCAT S $P(^(0),"^",2)=$P(^(0),"^",2)+PSGWQD S GOTIT=1 Q
I GOTIT Q
S DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""DRG"","_DRGDA_",""CAT"",",DIC(0)="LM",X=PSGWCAT,DA(3)=PSGWADT,DA(2)=SITE,DA(1)=DRGDA,DIC("DR")="1///"_PSGWQD K DD,DO D FILE^DICN K DIC Q
SETRET ;
D NEW S:'$D(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",0)) ^(0)="^58.51S^^"
I '$D(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD)) S DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""AMIS"",",DIC(0)="LM",X=FLD,DA(2)=PSGWADT,DA(1)=SITE,DIC("DR")="3///"_DOSE_";4///"_COST K DD,DO D FILE^DICN K DIC Q
S FLDA=$O(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD,0)),$P(^(0),"^",4)=$P(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",FLDA,0),"^",4)+DOSE,$P(^(0),"^",5)=$P(^(0),"^",5)+COST
Q
NEW ;
I '$D(^PSI(58.5,"B",PSGWADT)) S DIC="^PSI(58.5,",DIC(0)="LM",DLAYGO=58.5,(DINUM,X)=PSGWADT K DD,DO D FILE^DICN K DIC,DLAYGO
S:'$D(^PSI(58.5,PSGWADT,"S",0)) ^(0)="^58.501PA^^" I '$D(^PSI(58.5,PSGWADT,"S",SITE,0)) S DIC="^PSI(58.5,"_PSGWADT_",""S"",",DIC(0)="LM",(DINUM,X)=SITE,DA(1)=PSGWADT K DD,DO D FILE^DICN K DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWCAD 3661 printed Apr 09, 2024@20:43:52 Page 2
PSGWCAD ;BHAM ISC/PTD,CML-Calculate and Store AMIS Data ; 29 Dec 93 / 9:13 AM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 ;Calling routine passes these variables: PSGWADT -AMIS Date, PSGWDN -drug number, PSGWQD -quantity dispensed, PSGWCAT -AMIS category, PSGWAOU -AOU for returns, SITE -for INPATIENT SITE for AOU.
+3 ;IF COMPLETE DATA IS NOT AVAILABLE, SET MISSING DATA FLAG. DO RECALC.
CHKDTA SET INC=0
IF PSGWCAT="R"
IF '$DATA(^PSI(58.1,PSGWAOU,0))
WRITE !!,"Data missing - contact ADP personnel.",!,"The zero node for this AOU is missing.",!!,"No AMIS update made for this return!"
GOTO END
+1 IF PSGWCAT="R"
SET LOC3=^PSI(58.1,PSGWAOU,0)
SET PSGWCAT=PSGWCAT_$SELECT($PIECE(LOC3,"^",2)="W":"W",1:"A")
+2 IF $DATA(^PSDRUG(PSGWDN,660))
SET LOC1=^(660)
+3 IF '$TEST
SET INC=1
DO RECALC
GOTO END
+4 IF $DATA(^PSDRUG(PSGWDN,"PSG"))
SET LOC2=^("PSG")
+5 IF '$TEST
SET INC=1
DO RECALC
GOTO END
+6 FOR J=3,5,6
IF $PIECE(LOC1,"^",J)=""
SET INC=1
DO RECALC
GOTO END
+7 FOR J=2,3
IF $PIECE(LOC2,"^",J)=""
SET INC=1
DO RECALC
GOTO END
+8 ;
MAIN DO CALC
IF PSGWCAT["R"
DO SETRET
DO RECALC
GOTO END
+1 DO SETDSP
DO RECALC
END KILL INC,LOC1,LOC2,LOC3,J,DOSE,COST,FLD,CAT,DTDA,DRGDA,FLDA,DA,DR,GOTIT
SET PSGWCAT=$EXTRACT(PSGWCAT)
+1 QUIT
+2 ;
CALC ;COMPLETE DATA IS AVAILABLE, SO CALCULATE AMIS DATA.
+1 SET DOSE=PSGWQD*$PIECE(LOC2,"^",3)
SET COST=PSGWQD*$PIECE(LOC1,"^",6)
+2 IF PSGWCAT="A"
SET FLD=$SELECT($PIECE(LOC2,"^",2)=0:"04",$PIECE(LOC2,"^",2)=1:"07",$PIECE(LOC2,"^",2)=2:"17",1:"22")
+3 IF PSGWCAT="W"
SET FLD=$SELECT($PIECE(LOC2,"^",2)=0:"03",$PIECE(LOC2,"^",2)=1:"06",$PIECE(LOC2,"^",2)=2:"17",1:"22")
+4 IF PSGWCAT["R"
SET FLD=$SELECT($PIECE(LOC3,"^",2)="W":$SELECT($PIECE(LOC2,"^",2)=0:"03",$PIECE(LOC2,"^",2)=1:"06",$PIECE(LOC2,"^",2)=2:"17",1:"22"),1:$SELECT($PIECE(LOC2,"^",2)=0:"04",$PIECE(LOC2,"^",2)=1:"07",$PIECE(LOC2,"^",2)=2:"17",1:"22"))
+5 QUIT
+6 ;
SETDSP ;
+1 DO NEW
if '$DATA(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",0))
SET ^(0)="^58.51S^^"
+2 IF '$DATA(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD))
SET DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""AMIS"","
SET DIC(0)="LM"
SET X=FLD
SET DA(2)=PSGWADT
SET DA(1)=SITE
SET DIC("DR")="1///"_DOSE_";2///"_COST
KILL DD,DO
DO FILE^DICN
KILL DIC
QUIT
+3 SET FLDA=$ORDER(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD,0))
SET $PIECE(^(0),"^",2)=$PIECE(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",FLDA,0),"^",2)+DOSE
SET $PIECE(^(0),"^",3)=$PIECE(^(0),"^",3)+COST
+4 QUIT
RECALC ;
+1 DO NEW
if '$DATA(^PSI(58.5,PSGWADT,"S",SITE,"DRG",0))
SET ^(0)="^58.52P^^"
+2 IF '$DATA(^PSI(58.5,"D",PSGWDN,PSGWADT,SITE))
SET DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""DRG"","
SET DIC(0)="LM"
SET X=PSGWDN
SET DA(2)=PSGWADT
SET DA(1)=SITE
SET DIC("DR")="2///"_INC
KILL DD,DO
DO FILE^DICN
KILL DIC
+3 SET DRGDA=$ORDER(^PSI(58.5,"D",PSGWDN,PSGWADT,SITE,0))
IF '$DATA(^PSI(58.5,PSGWADT,"S",SITE,"DRG",DRGDA,"CAT",0))
SET ^(0)="^58.53SA^^"
+4 SET GOTIT=0
FOR CAT=0:0
SET CAT=$ORDER(^PSI(58.5,PSGWADT,"S",SITE,"DRG",DRGDA,"CAT",CAT))
if 'CAT
QUIT
IF $PIECE(^(CAT,0),"^")=PSGWCAT
SET $PIECE(^(0),"^",2)=$PIECE(^(0),"^",2)+PSGWQD
SET GOTIT=1
QUIT
+5 IF GOTIT
QUIT
+6 SET DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""DRG"","_DRGDA_",""CAT"","
SET DIC(0)="LM"
SET X=PSGWCAT
SET DA(3)=PSGWADT
SET DA(2)=SITE
SET DA(1)=DRGDA
SET DIC("DR")="1///"_PSGWQD
KILL DD,DO
DO FILE^DICN
KILL DIC
QUIT
SETRET ;
+1 DO NEW
if '$DATA(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",0))
SET ^(0)="^58.51S^^"
+2 IF '$DATA(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD))
SET DIC="^PSI(58.5,"_PSGWADT_",""S"","_SITE_",""AMIS"","
SET DIC(0)="LM"
SET X=FLD
SET DA(2)=PSGWADT
SET DA(1)=SITE
SET DIC("DR")="3///"_DOSE_";4///"_COST
KILL DD,DO
DO FILE^DICN
KILL DIC
QUIT
+3 SET FLDA=$ORDER(^PSI(58.5,PSGWADT,"S",SITE,"AMIS","FLD",FLD,0))
SET $PIECE(^(0),"^",4)=$PIECE(^PSI(58.5,PSGWADT,"S",SITE,"AMIS",FLDA,0),"^",4)+DOSE
SET $PIECE(^(0),"^",5)=$PIECE(^(0),"^",5)+COST
+4 QUIT
NEW ;
+1 IF '$DATA(^PSI(58.5,"B",PSGWADT))
SET DIC="^PSI(58.5,"
SET DIC(0)="LM"
SET DLAYGO=58.5
SET (DINUM,X)=PSGWADT
KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO
+2 if '$DATA(^PSI(58.5,PSGWADT,"S",0))
SET ^(0)="^58.501PA^^"
IF '$DATA(^PSI(58.5,PSGWADT,"S",SITE,0))
SET DIC="^PSI(58.5,"_PSGWADT_",""S"","
SET DIC(0)="LM"
SET (DINUM,X)=SITE
SET DA(1)=PSGWADT
KILL DD,DO
DO FILE^DICN
KILL DIC
+3 QUIT
