- PSDFIL2 ;BIR/JPW,BJW-File TRAKKER Info - Vault Inv Adj ; 04 FEB 99
- ;;3.0; CONTROLLED SUBSTANCES ;**8,3,19,66**;13 Feb 97;Build 3
- ;nois#:cla-0199-20993; no reference to DBIAS's needed
- ;**Y2K compliance**after FM patch DI*21*44 installed
- EN1 ;entry for filing vault inventory adjustments trakker info
- K CNT,DA,DATA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSDS,PSDSN,X,X1,Y
- LOOP ;loop thru ^tmp
- K CNT S CNT=1
- W !!,"Updating DHCP now..."
- F PSD=0:0 S PSD=$O(^TMP("PSDWN2",$J,PSD)) Q:'PSD S NODE=^TMP("PSDWN2",$J,PSD,0) D
- .;DAVE B (PSD*3*19 12MAY99) Added length check
- .I NODE'["*",$L(NODE,"^")=2 S PHARM=$P(NODE,"^") S:$E(PHARM)="P" PHARM=$P(PHARM,"P",2) S PHARM=$P(PHARM,"-")_$P(PHARM,"-",2)_$P(PHARM,"-",3) D Q
- ..S PHARM=$S(PHARM]"":+$O(^VA(200,"SSN",PHARM,0)),1:"")
- ..S PSDTS=$P(NODE,">",2),X=$E(PSDTS,1,2) D ^%DT S PSDTS=$E(Y,1,3)_$E(PSDTS,4,5)_$E(PSDTS,7,8)_"."_$E(PSDTS,10,11)_$E(PSDTS,13,14)_$E(PSDTS,16,17),PSDTS=+PSDTS
- .I $L(NODE)<32,NODE["*" S PSDS=+$P(NODE,"*",2),PSDSN=$S($P($G(^PSD(58.8,PSDS,0)),"^")]"":$P($G(^(0)),"^"),1:"UNKNOWN") Q
- .S PHARM1=$P(NODE,"^"),PSDRN=$P(NODE,"^",3),OQTY=+$P(NODE,"^",4),QTY=+$P(NODE,"^",6),PHARM2=$P(NODE,"^",7)
- .S CQTY=+$P(NODE,"^",8),PSDTA=$P(NODE,"^",12)
- .S:$E(PHARM1)="P" PHARM1=$P(PHARM1,"P",2) S PHARM1=$P(PHARM1,"-")_$P(PHARM1,"-",2)_$P(PHARM1,"-",3),PHARM1=$S(PHARM1]"":+$O(^VA(200,"SSN",PHARM1,0)),1:"")
- .I PHARM2]"" S:$E(PHARM2)="P" PHARM2=$P(PHARM2,"P",2) S PHARM2=$P(PHARM2,"-")_$P(PHARM2,"-",2)_$P(PHARM2,"-",3),PHARM2=$S(PHARM2]"":+$O(^VA(200,"SSN",PHARM2,0)),1:"")
- .S PSDR=+$P(NODE,"^",2)
- .S X=$E(PSDTA,2,3) D ^%DT S PSDTA=$E(Y,1,3)_$E(PSDTA,5,6)_$E(PSDTA,8,9)_"."_$E(PSDTA,11,12)_$E(PSDTA,14,15)_$E(PSDTA,17,18),PSDTA=+PSDTA
- .S PSDTYP=$S('CQTY:20,1:9)
- .;I PSDTYP=9,CQTY=OQTY Q
- .I '$D(^TMP("PSDOK2",$J,19,+PSDR)) S ^TMP("PSDOK2",$J,19,+PSDR,+PSDTS,1)=19_"^"_PHARM_"^^^"
- .S ^TMP("PSDOK2",$J,+PSDTYP,+PSDR,+PSDTA,CNT)=PSDTYP_"^"_PHARM1_"^"_PHARM2_"^"_OQTY_"^"_CQTY
- .S CNT=CNT+1
- FIL ;file data
- S PSD="" F PSD=19,9,20 D
- .S PSDR="" F S PSDR=$O(^TMP("PSDOK2",$J,PSD,PSDR)) Q:PSDR="" S PSDTA="" F S PSDTA=$O(^TMP("PSDOK2",$J,PSD,PSDR,PSDTA)) Q:PSDTA="" S CNT="" F S CNT=$O(^TMP("PSDOK2",$J,PSD,PSDR,PSDTA,CNT)) Q:CNT="" D
- ..S NODE=^TMP("PSDOK2",$J,PSD,+PSDR,+PSDTA,CNT),PSDTYP=+$P(NODE,"^"),PHARM1=$P(NODE,"^",2),PHARM2=$P(NODE,"^",3),OQTY=$P(NODE,"^",4),CQTY=$P(NODE,"^",5),QTY=$S(PSDTYP=9:CQTY-OQTY,1:0)
- ..S PHARMN1=$S($P($G(^VA(200,+PHARM1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- ..D UPDATE
- W "done.",!
- END ;kill variables
- K %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,NAOU,NODE,OK,OQTY
- K PHARM,PHARM1,PHARM2,PHARMN1,PAT,PSD,PSDER,PSDR,PSDREC,PSDRN,PSDS,PSDSN,PSDT,PSDTA,PSDTS,PSDTYP,QTY,X,Y
- K ^TMP("PSDWN2",$J)
- K ^TMP("PSDOK2",$J)
- Q
- UPDATE ;update 58.8 and 58.81
- ;vault balance
- F L +^PSD(58.8,+PSDS,1,+PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- D NOW^%DTC S PSDT=+%
- S BAL=$P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+QTY
- L -^PSD(58.8,+PSDS,1,+PSDR,0)
- F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- FIND S PSDREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDREC)) S $P(^PSD(58.81,0),"^",3)=PSDREC G FIND
- K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO
- L -^PSD(58.81,0)
- EDIT ;edit new transaction in 58.81
- S ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP_"^"_+PSDS_"^"_$S(PSDTYP=19:PSDTS,1:PSDT)_"^"_PSDR_"^"_QTY_"^"_$S(PSDTYP=9:PHARM1,1:PHARM)_"^^^"_BAL_"^^^^^^"_$S(PSDTYP=9:"TRAKKER ADJUSTMENT",1:"TRAKKER INVENTORY")
- S:PSDTYP=9 ^PSD(58.81,PSDREC,9)="^^"_$S(PSDTYP=19:BAL,1:OQTY)_"^^^^"_CQTY_"^"_PHARM1_"^"_PHARM2_"^"_PSDTA
- S ^PSD(58.81,PSDREC,"CS")=1
- K DA,DIK S DA=PSDREC,DIK="^PSD(58.81," D IX^DIK K DA,DIK
- ;update vault
- I '$D(^PSD(58.8,+PSDS,1,+PSDR,4,0)) S ^(0)="^58.800119PA^^"
- I '$D(^PSD(58.8,+PSDS,1,+PSDR,4,+PSDREC,0)) K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+PSDS_",1,"_+PSDR_",4,",DA(2)=+PSDS,DA(1)=+PSDR,(X,DINUM)=PSDREC D FILE^DICN K DA,DIC,DD,D0
- I PSDTYP'=9 W "." Q
- ERR ;err log update
- F L +^PSD(58.89,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- FIND9 S PSDER=$P(^PSD(58.89,0),"^",3)+1 I $D(^PSD(58.89,PSDER)) S $P(^PSD(58.89,0),"^",3)=PSDER G FIND9
- K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.89,(X,DINUM)=PSDER D ^DIC K DIC,DLAYGO
- L -^PSD(58.89,0)
- EDIT9 ;edit error log
- K DA,DIE,DR S DA=PSDER,DIE=58.89,DR="1////"_PSDREC_";2////"_PSDT_";6////"_+PSDS D ^DIE K DA,DIE,DR
- D ^PSDFILM
- W "."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDFIL2 4450 printed Feb 18, 2025@23:12:25 Page 2
- PSDFIL2 ;BIR/JPW,BJW-File TRAKKER Info - Vault Inv Adj ; 04 FEB 99
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**8,3,19,66**;13 Feb 97;Build 3
- +2 ;nois#:cla-0199-20993; no reference to DBIAS's needed
- +3 ;**Y2K compliance**after FM patch DI*21*44 installed
- EN1 ;entry for filing vault inventory adjustments trakker info
- +1 KILL CNT,DA,DATA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSDS,PSDSN,X,X1,Y
- LOOP ;loop thru ^tmp
- +1 KILL CNT
- SET CNT=1
- +2 WRITE !!,"Updating DHCP now..."
- +3 FOR PSD=0:0
- SET PSD=$ORDER(^TMP("PSDWN2",$JOB,PSD))
- if 'PSD
- QUIT
- SET NODE=^TMP("PSDWN2",$JOB,PSD,0)
- Begin DoDot:1
- +4 ;DAVE B (PSD*3*19 12MAY99) Added length check
- +5 IF NODE'["*"
- IF $LENGTH(NODE,"^")=2
- SET PHARM=$PIECE(NODE,"^")
- if $EXTRACT(PHARM)="P"
- SET PHARM=$PIECE(PHARM,"P",2)
- SET PHARM=$PIECE(PHARM,"-")_$PIECE(PHARM,"-",2)_$PIECE(PHARM,"-",3)
- Begin DoDot:2
- +6 SET PHARM=$SELECT(PHARM]"":+$ORDER(^VA(200,"SSN",PHARM,0)),1:"")
- +7 SET PSDTS=$PIECE(NODE,">",2)
- SET X=$EXTRACT(PSDTS,1,2)
- DO ^%DT
- SET PSDTS=$EXTRACT(Y,1,3)_$EXTRACT(PSDTS,4,5)_$EXTRACT(PSDTS,7,8)_"."_$EXTRACT(PSDTS,10,11)_$EXTRACT(PSDTS,13,14)_$EXTRACT(PSDTS,16,17)
- SET PSDTS=+PSDTS
- End DoDot:2
- QUIT
- +8 IF $LENGTH(NODE)<32
- IF NODE["*"
- SET PSDS=+$PIECE(NODE,"*",2)
- SET PSDSN=$SELECT($PIECE($GET(^PSD(58.8,PSDS,0)),"^")]"":$PIECE($GET(^(0)),"^"),1:"UNKNOWN")
- QUIT
- +9 SET PHARM1=$PIECE(NODE,"^")
- SET PSDRN=$PIECE(NODE,"^",3)
- SET OQTY=+$PIECE(NODE,"^",4)
- SET QTY=+$PIECE(NODE,"^",6)
- SET PHARM2=$PIECE(NODE,"^",7)
- +10 SET CQTY=+$PIECE(NODE,"^",8)
- SET PSDTA=$PIECE(NODE,"^",12)
- +11 if $EXTRACT(PHARM1)="P"
- SET PHARM1=$PIECE(PHARM1,"P",2)
- SET PHARM1=$PIECE(PHARM1,"-")_$PIECE(PHARM1,"-",2)_$PIECE(PHARM1,"-",3)
- SET PHARM1=$SELECT(PHARM1]"":+$ORDER(^VA(200,"SSN",PHARM1,0)),1:"")
- +12 IF PHARM2]""
- if $EXTRACT(PHARM2)="P"
- SET PHARM2=$PIECE(PHARM2,"P",2)
- SET PHARM2=$PIECE(PHARM2,"-")_$PIECE(PHARM2,"-",2)_$PIECE(PHARM2,"-",3)
- SET PHARM2=$SELECT(PHARM2]"":+$ORDER(^VA(200,"SSN",PHARM2,0)),1:"")
- +13 SET PSDR=+$PIECE(NODE,"^",2)
- +14 SET X=$EXTRACT(PSDTA,2,3)
- DO ^%DT
- SET PSDTA=$EXTRACT(Y,1,3)_$EXTRACT(PSDTA,5,6)_$EXTRACT(PSDTA,8,9)_"."_$EXTRACT(PSDTA,11,12)_$EXTRACT(PSDTA,14,15)_$EXTRACT(PSDTA,17,18)
- SET PSDTA=+PSDTA
- +15 SET PSDTYP=$SELECT('CQTY:20,1:9)
- +16 ;I PSDTYP=9,CQTY=OQTY Q
- +17 IF '$DATA(^TMP("PSDOK2",$JOB,19,+PSDR))
- SET ^TMP("PSDOK2",$JOB,19,+PSDR,+PSDTS,1)=19_"^"_PHARM_"^^^"
- +18 SET ^TMP("PSDOK2",$JOB,+PSDTYP,+PSDR,+PSDTA,CNT)=PSDTYP_"^"_PHARM1_"^"_PHARM2_"^"_OQTY_"^"_CQTY
- +19 SET CNT=CNT+1
- End DoDot:1
- FIL ;file data
- +1 SET PSD=""
- FOR PSD=19,9,20
- Begin DoDot:1
- +2 SET PSDR=""
- FOR
- SET PSDR=$ORDER(^TMP("PSDOK2",$JOB,PSD,PSDR))
- if PSDR=""
- QUIT
- SET PSDTA=""
- FOR
- SET PSDTA=$ORDER(^TMP("PSDOK2",$JOB,PSD,PSDR,PSDTA))
- if PSDTA=""
- QUIT
- SET CNT=""
- FOR
- SET CNT=$ORDER(^TMP("PSDOK2",$JOB,PSD,PSDR,PSDTA,CNT))
- if CNT=""
- QUIT
- Begin DoDot:2
- +3 SET NODE=^TMP("PSDOK2",$JOB,PSD,+PSDR,+PSDTA,CNT)
- SET PSDTYP=+$PIECE(NODE,"^")
- SET PHARM1=$PIECE(NODE,"^",2)
- SET PHARM2=$PIECE(NODE,"^",3)
- SET OQTY=$PIECE(NODE,"^",4)
- SET CQTY=$PIECE(NODE,"^",5)
- SET QTY=$SELECT(PSDTYP=9:CQTY-OQTY,1:0)
- +4 SET PHARMN1=$SELECT($PIECE($GET(^VA(200,+PHARM1,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +5 DO UPDATE
- End DoDot:2
- End DoDot:1
- +6 WRITE "done.",!
- END ;kill variables
- +1 KILL %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,NAOU,NODE,OK,OQTY
- +2 KILL PHARM,PHARM1,PHARM2,PHARMN1,PAT,PSD,PSDER,PSDR,PSDREC,PSDRN,PSDS,PSDSN,PSDT,PSDTA,PSDTS,PSDTYP,QTY,X,Y
- +3 KILL ^TMP("PSDWN2",$JOB)
- +4 KILL ^TMP("PSDOK2",$JOB)
- +5 QUIT
- UPDATE ;update 58.8 and 58.81
- +1 ;vault balance
- +2 FOR
- LOCK +^PSD(58.8,+PSDS,1,+PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +3 DO NOW^%DTC
- SET PSDT=+%
- +4 SET BAL=$PIECE(^PSD(58.8,+PSDS,1,+PSDR,0),"^",4)
- SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+QTY
- +5 LOCK -^PSD(58.8,+PSDS,1,+PSDR,0)
- +6 FOR
- LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- FIND SET PSDREC=$PIECE(^PSD(58.81,0),"^",3)+1
- IF $DATA(^PSD(58.81,PSDREC))
- SET $PIECE(^PSD(58.81,0),"^",3)=PSDREC
- GOTO FIND
- +1 KILL DIC,DLAYGO
- SET DIC(0)="L"
- SET (DIC,DLAYGO)=58.81
- SET (X,DINUM)=PSDREC
- DO ^DIC
- KILL DIC,DLAYGO
- +2 LOCK -^PSD(58.81,0)
- EDIT ;edit new transaction in 58.81
- +1 SET ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP_"^"_+PSDS_"^"_$SELECT(PSDTYP=19:PSDTS,1:PSDT)_"^"_PSDR_"^"_QTY_"^"_$SELECT(PSDTYP=9:PHARM1,1:PHARM)_"^^^"_BAL_"^^^^^^"_$SELECT(PSDTYP=9:"TRAKKER ADJUSTMENT",1:"TRAKKER INVENTORY")
- +2 if PSDTYP=9
- SET ^PSD(58.81,PSDREC,9)="^^"_$SELECT(PSDTYP=19:BAL,1:OQTY)_"^^^^"_CQTY_"^"_PHARM1_"^"_PHARM2_"^"_PSDTA
- +3 SET ^PSD(58.81,PSDREC,"CS")=1
- +4 KILL DA,DIK
- SET DA=PSDREC
- SET DIK="^PSD(58.81,"
- DO IX^DIK
- KILL DA,DIK
- +5 ;update vault
- +6 IF '$DATA(^PSD(58.8,+PSDS,1,+PSDR,4,0))
- SET ^(0)="^58.800119PA^^"
- +7 IF '$DATA(^PSD(58.8,+PSDS,1,+PSDR,4,+PSDREC,0))
- KILL DA,DIC,DD,DO
- SET DIC(0)="L"
- SET DIC="^PSD(58.8,"_+PSDS_",1,"_+PSDR_",4,"
- SET DA(2)=+PSDS
- SET DA(1)=+PSDR
- SET (X,DINUM)=PSDREC
- DO FILE^DICN
- KILL DA,DIC,DD,D0
- +8 IF PSDTYP'=9
- WRITE "."
- QUIT
- ERR ;err log update
- +1 FOR
- LOCK +^PSD(58.89,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- FIND9 SET PSDER=$PIECE(^PSD(58.89,0),"^",3)+1
- IF $DATA(^PSD(58.89,PSDER))
- SET $PIECE(^PSD(58.89,0),"^",3)=PSDER
- GOTO FIND9
- +1 KILL DIC,DLAYGO
- SET DIC(0)="L"
- SET (DIC,DLAYGO)=58.89
- SET (X,DINUM)=PSDER
- DO ^DIC
- KILL DIC,DLAYGO
- +2 LOCK -^PSD(58.89,0)
- EDIT9 ;edit error log
- +1 KILL DA,DIE,DR
- SET DA=PSDER
- SET DIE=58.89
- SET DR="1////"_PSDREC_";2////"_PSDT_";6////"_+PSDS
- DO ^DIE
- KILL DA,DIE,DR
- +2 DO ^PSDFILM
- +3 WRITE "."
- +4 QUIT