- PSAUDP ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97
- ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64,66,73**; 10/24/97;Build 3
- ;
- ;Reference to ^PS(57.6 are covered by IA #772
- PICKLST ;ask for parameters PSA*3*25
- I '$D(^PSD(58.812,1,"T","B","UNIT DOSE"))!('$D(^PSD(58.812,1,"T"))) D
- .S ^PSD(58.812,1,"T",0)="^58.8123A^1^1"
- .S X="T-2W" D ^%DT S ^PSD(58.812,1,"T",1,0)="UNIT DOSE^"_Y_"^",X="T-1W" D ^%DT S $P(^PSD(58.812,1,"T",1,0),"^",3)=Y K X,Y
- .S ^PSD(58.812,1,"T","B","UNIT DOSE",1)=""
- S XX=$O(^PSD(58.812,1,"T","B","UNIT DOSE",0)) Q:XX'>0 S JOBIEN=XX D NOW^%DTC S STRTDATE=%,PARDATA=$G(^PSD(58.812,1,"T",JOBIEN,0))
- S PSABGN=$P(PARDATA,"^",2),PSAEND=$P(PARDATA,"^",3)
- S X="T-7" D ^%DT I Y'=PSAEND G DONE
- S $P(^PSD(58.812,1,"T",JOBIEN,0),"^",2)=PSAEND,X1=PSAEND,X2=7 D C^%DTC S $P(^PSD(58.812,1,"T",JOBIEN,0),"^",3)=X ;Reset date parameters
- ;Go back two weeks, gather 1 weeks worth of data
- S PSAD0=PSABGN-.000001
- S PSAEND=PSAEND_".2359"
- DATE ;Loop through dates
- S PSAD0=$O(^PS(57.6,PSAD0)) G DONE:PSAD0'>0 G DONE:PSAD0>PSAEND K PSAD1
- WRD S PSAD1=$S('$D(PSAD1):$O(^PS(57.6,PSAD0,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1))) G DATE:PSAD1'>0 K PSAD2
- PVDR ;Loop through providers
- S PSAD2=$S('$D(PSAD2):$O(^PS(57.6,PSAD0,1,PSAD1,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2))) G WRD:PSAD2'>0 K PSAD3
- DRG S PSAD3=$S('$D(PSAD3):$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3))) G PVDR:PSAD3'>0 S DATA=$G(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3,0))
- S PSAIP=PSAD1,PSA50=PSAD3,PSADT=PSAD0 K PSALOC
- LOC S PSALOC=$S('$D(PSALOC):$O(^PSD(58.8,"AB",PSAD1,0)),1:$O(^PSD(58.8,"AB",PSAD1,PSALOC))) G DRG:PSALOC'>0 I $D(^PSD(58.8,PSALOC,"I")),+$P($G(^PSD(58.8,PSALOC,"I")),"^")'=0,$P($G(^PSD(58.8,PSALOC,"I")),"^")'>DT G LOC ;;<*73-RJS>
- S PSAQTY=$P($G(DATA),"^",2)-$P($G(DATA),"^",4)
- I $D(^PSD(58.8,PSALOC,1,PSA50)) D PROCESS
- G LOC
- ;
- Q
- DONE ;
- END K DA,DATA,DIC,DIE,DR,PSA50,PSAD0,PSAD1,PSAD2,PSAD3,PSADT,PSAIP,PSALOC,PSANUM,PSAQTY,X,Y,PSABGN,PSAEND,PARDATA,JOBIEN,X
- Q
- PROCESS ;Stuff last UD dispensing fld with DT
- F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- S DIE="^PSD(58.8,",DA=PSALOC,DR="27////"_PSADT D ^DIE K DIE,DA,DR
- ;Subtract dispensing from balance
- S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSA50,0)),"^",4)
- S $P(^PSD(58.8,PSALOC,1,PSA50,0),"^",4)=PSABAL-$G(PSAQTY)
- ;If no monthly activity node, add node with beginning balance.
- I '$D(^PSD(58.8,PSALOC,1,PSA50,5,+$E(PSADT,1,5)*100,0)) D
- .S DIC="^PSD(58.8,PSALOC,1,PSA50,5,",DIC(0)="L",DIC("P")=$P(^DD(58.8001,20,0),U,2),(X,DINUM)=$E(PSADT,1,5)*100,DA(2)=PSALOC,DA(1)=PSA50
- .S DIC("DR")="1////^S X=$G(PSABAL)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO
- .;Add current month's node and stuff beginning & ending balance.
- .S DIC="^PSD(58.8,PSALOC,1,PSA50,5,",DIC(0)="L",(X,DINUM)=$E(PSADT-100-(+$E(PSADT,4,5)=1*8800),1,5)*100,DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DIC,DLAYGO S DA=+Y
- .S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
- ;Stuff total dispensed
- S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DA=$E(PSADT,1,5)*100,DR="9////^S X=$P($G(^(0)),U,6)+PSAQTY" D ^DIE K DIE,DA
- ;Get next transaction node number
- F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q ;; << *66 RJS
- FIND S PSANUM=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSANUM)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
- ;Add next transaction node with data.
- S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSANUM D ^DIC K DIC,DLAYGO
- S DIE="^PSD(58.81,",DA=PSANUM
- S DR="1////2;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSA50;5////^S X=PSAQTY;9////^S X=$G(PSABAL)" D ^DIE K DIE,DA
- L -^PSD(58.81,0) ;; >> *66 RJS
- ;Add activity node
- S DIC="^PSD(58.8,PSALOC,1,PSA50,4,",DIC(0)="L",(X,DINUM)=PSANUM,DIC("P")=$P(^DD(58.8001,19,0),"^",2),DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO
- L -^PSD(58.8,PSALOC,0)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAUDP 3978 printed Feb 18, 2025@23:17:04 Page 2
- PSAUDP ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97
- +1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64,66,73**; 10/24/97;Build 3
- +2 ;
- +3 ;Reference to ^PS(57.6 are covered by IA #772
- PICKLST ;ask for parameters PSA*3*25
- +1 IF '$DATA(^PSD(58.812,1,"T","B","UNIT DOSE"))!('$DATA(^PSD(58.812,1,"T")))
- Begin DoDot:1
- +2 SET ^PSD(58.812,1,"T",0)="^58.8123A^1^1"
- +3 SET X="T-2W"
- DO ^%DT
- SET ^PSD(58.812,1,"T",1,0)="UNIT DOSE^"_Y_"^"
- SET X="T-1W"
- DO ^%DT
- SET $PIECE(^PSD(58.812,1,"T",1,0),"^",3)=Y
- KILL X,Y
- +4 SET ^PSD(58.812,1,"T","B","UNIT DOSE",1)=""
- End DoDot:1
- +5 SET XX=$ORDER(^PSD(58.812,1,"T","B","UNIT DOSE",0))
- if XX'>0
- QUIT
- SET JOBIEN=XX
- DO NOW^%DTC
- SET STRTDATE=%
- SET PARDATA=$GET(^PSD(58.812,1,"T",JOBIEN,0))
- +6 SET PSABGN=$PIECE(PARDATA,"^",2)
- SET PSAEND=$PIECE(PARDATA,"^",3)
- +7 SET X="T-7"
- DO ^%DT
- IF Y'=PSAEND
- GOTO DONE
- +8 ;Reset date parameters
- SET $PIECE(^PSD(58.812,1,"T",JOBIEN,0),"^",2)=PSAEND
- SET X1=PSAEND
- SET X2=7
- DO C^%DTC
- SET $PIECE(^PSD(58.812,1,"T",JOBIEN,0),"^",3)=X
- +9 ;Go back two weeks, gather 1 weeks worth of data
- +10 SET PSAD0=PSABGN-.000001
- +11 SET PSAEND=PSAEND_".2359"
- DATE ;Loop through dates
- +1 SET PSAD0=$ORDER(^PS(57.6,PSAD0))
- if PSAD0'>0
- GOTO DONE
- if PSAD0>PSAEND
- GOTO DONE
- KILL PSAD1
- WRD SET PSAD1=$SELECT('$DATA(PSAD1):$ORDER(^PS(57.6,PSAD0,1,0)),1:$ORDER(^PS(57.6,PSAD0,1,PSAD1)))
- if PSAD1'>0
- GOTO DATE
- KILL PSAD2
- PVDR ;Loop through providers
- +1 SET PSAD2=$SELECT('$DATA(PSAD2):$ORDER(^PS(57.6,PSAD0,1,PSAD1,1,0)),1:$ORDER(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2)))
- if PSAD2'>0
- GOTO WRD
- KILL PSAD3
- DRG SET PSAD3=$SELECT('$DATA(PSAD3):$ORDER(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,0)),1:$ORDER(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3)))
- if PSAD3'>0
- GOTO PVDR
- SET DATA=$GET(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3,0))
- +1 SET PSAIP=PSAD1
- SET PSA50=PSAD3
- SET PSADT=PSAD0
- KILL PSALOC
- LOC ;;<*73-RJS>
- SET PSALOC=$SELECT('$DATA(PSALOC):$ORDER(^PSD(58.8,"AB",PSAD1,0)),1:$ORDER(^PSD(58.8,"AB",PSAD1,PSALOC)))
- if PSALOC'>0
- GOTO DRG
- IF $DATA(^PSD(58.8,PSALOC,"I"))
- IF +$PIECE($GET(^PSD(58.8,PSALOC,"I")),"^")'=0
- IF $PIECE($GET(^PSD(58.8,PSALOC,"I")),"^")'>DT
- GOTO LOC
- +1 SET PSAQTY=$PIECE($GET(DATA),"^",2)-$PIECE($GET(DATA),"^",4)
- +2 IF $DATA(^PSD(58.8,PSALOC,1,PSA50))
- DO PROCESS
- +3 GOTO LOC
- +4 ;
- +5 QUIT
- DONE ;
- END KILL DA,DATA,DIC,DIE,DR,PSA50,PSAD0,PSAD1,PSAD2,PSAD3,PSADT,PSAIP,PSALOC,PSANUM,PSAQTY,X,Y,PSABGN,PSAEND,PARDATA,JOBIEN,X
- +1 QUIT
- PROCESS ;Stuff last UD dispensing fld with DT
- +1 FOR
- LOCK +^PSD(58.8,PSALOC,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +2 SET DIE="^PSD(58.8,"
- SET DA=PSALOC
- SET DR="27////"_PSADT
- DO ^DIE
- KILL DIE,DA,DR
- +3 ;Subtract dispensing from balance
- +4 SET PSABAL=$PIECE($GET(^PSD(58.8,PSALOC,1,PSA50,0)),"^",4)
- +5 SET $PIECE(^PSD(58.8,PSALOC,1,PSA50,0),"^",4)=PSABAL-$GET(PSAQTY)
- +6 ;If no monthly activity node, add node with beginning balance.
- +7 IF '$DATA(^PSD(58.8,PSALOC,1,PSA50,5,+$EXTRACT(PSADT,1,5)*100,0))
- Begin DoDot:1
- +8 SET DIC="^PSD(58.8,PSALOC,1,PSA50,5,"
- SET DIC(0)="L"
- SET DIC("P")=$PIECE(^DD(58.8001,20,0),U,2)
- SET (X,DINUM)=$EXTRACT(PSADT,1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSA50
- +9 SET DIC("DR")="1////^S X=$G(PSABAL)"
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC,DLAYGO
- +10 ;Add current month's node and stuff beginning & ending balance.
- +11 SET DIC="^PSD(58.8,PSALOC,1,PSA50,5,"
- SET DIC(0)="L"
- SET (X,DINUM)=$EXTRACT(PSADT-100-(+$EXTRACT(PSADT,4,5)=1*8800),1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSA50
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC,DLAYGO
- SET DA=+Y
- +12 SET DIE="^PSD(58.8,PSALOC,1,PSA50,5,"
- SET DA(2)=PSALOC
- SET DA(1)=PSA50
- SET DR="3////^S X=$G(PSABAL)"
- DO ^DIE
- KILL DIE
- End DoDot:1
- +13 ;Stuff total dispensed
- +14 SET DIE="^PSD(58.8,PSALOC,1,PSA50,5,"
- SET DA(2)=PSALOC
- SET DA(1)=PSA50
- SET DA=$EXTRACT(PSADT,1,5)*100
- SET DR="9////^S X=$P($G(^(0)),U,6)+PSAQTY"
- DO ^DIE
- KILL DIE,DA
- +15 ;Get next transaction node number
- +16 ;; << *66 RJS
- FOR
- LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- FIND SET PSANUM=$PIECE(^PSD(58.81,0),"^",3)+1
- IF $DATA(^PSD(58.81,PSANUM))
- SET $PIECE(^PSD(58.81,0),"^",3)=$PIECE(^PSD(58.81,0),"^",3)+1
- GOTO FIND
- +1 ;Add next transaction node with data.
- +2 SET DIC="^PSD(58.81,"
- SET DIC(0)="L"
- SET DLAYGO=58.81
- SET (DINUM,X)=PSANUM
- DO ^DIC
- KILL DIC,DLAYGO
- +3 SET DIE="^PSD(58.81,"
- SET DA=PSANUM
- +4 SET DR="1////2;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSA50;5////^S X=PSAQTY;9////^S X=$G(PSABAL)"
- DO ^DIE
- KILL DIE,DA
- +5 ;; >> *66 RJS
- LOCK -^PSD(58.81,0)
- +6 ;Add activity node
- +7 SET DIC="^PSD(58.8,PSALOC,1,PSA50,4,"
- SET DIC(0)="L"
- SET (X,DINUM)=PSANUM
- SET DIC("P")=$PIECE(^DD(58.8001,19,0),"^",2)
- SET DA(2)=PSALOC
- SET DA(1)=PSA50
- SET DLAYGO=58.8
- DO ^DIC
- KILL DA,DIC,DLAYGO
- +8 LOCK -^PSD(58.8,PSALOC,0)
- +9 QUIT