- PSAPSI1 ;BIR/LTL-IV Dispensing (Single Drug) & (All Drugs) ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
- ;This routine places the IV data into files 58.8 and 58.81. It is called
- ;by PSAPSI, PSAPSI2, AND PSAPSI3.
- ;
- N DIC,PSAD,PSAT
- S (PSA(4),PSA(6))=0 F S PSA(4)=$O(^TMP("PSA",$J,PSADRUG,PSA(4))) Q:'PSA(4) S PSA(6)=PSA(6)+1
- ;get transaction numbers
- F L +^PSD(58.81,0):0 I Q
- FIND S PSAD=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAD)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND
- S PSAT=PSAD,DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81
- F PSAD=PSAT:1:(PSAT+(PSA(6)-1)) S (DINUM,X)=PSAD D ^DIC
- L -^PSD(58.81,0) K DIC,DINUM,DLAYGO
- ;loop thru array
- LUP S PSA(4)=0 F S PSA(4)=$O(^TMP("PSA",$J,PSADRUG,PSA(4))) Q:'PSA(4) S PSA=$G(^TMP("PSA",$J,PSADRUG,PSA(4))) S:$P($G(^PSD(58.8,PSALOC,1,PSADRUG,6)),U,4) PSA=PSA/$P($G(^(6)),U,4) D LUP1
- K ^TMP("PSA",$J,PSADRUG)
- Q
- LUP1 ;get date + current balance + update balance
- F L +^PSD(58.8,PSALOC,1,PSADRUG,0):0 I Q
- S PSAB=$P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),U,4)
- G:'$G(PSA(7)) EDO
- S $P(^PSD(58.8,PSALOC,1,PSADRUG,0),U,4)=$P($G(^(0)),U,4)-PSA
- EDO L -^PSD(58.8,PSALOC,1,PSADRUG,0)
- S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,5,0)) ^(0)="^58.801A^^"
- I '$D(^PSD(58.8,PSALOC,1,PSADRUG,5,+$E(PSA(4),1,5)*100,0)) D
- .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSAB)",(X,DINUM)=$E(PSA(4),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO
- .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO S DA=+Y
- .S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG
- .S DR="3////^S X=$G(PSAB)" D ^DIE K DIE
- S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DR="9////^S X=$P($G(^(0)),U,6)+PSA",DA=$E(PSA(4),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG D ^DIE K DA
- ;update transaction
- S DIE="^PSD(58.81,",DR="1////15;2////^S X=PSALOC;3///^S X=PSA(4);4////^S X=PSADRUG;5////^S X=PSA;9////^S X=$G(PSAB)",DA=PSAT
- D ^DIE K DIE,DA,PSAB
- S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,4,0)) ^(0)="^58.800119PA^^"
- S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",4,",DIC(0)="L",(X,DINUM)=PSAT
- S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DA,DIC,DINUM,DLAYGO
- S DIE="^PSD(58.8,"_PSALOC_",1,",DA(1)=PSALOC,DA=PSADRUG,DR="24////^S X=PSA(4)_"",""_$G(PSAW(1))" D ^DIE S PSAT=PSAT+1
- Q
- PSAPSI1 ;BIR/LTL-IV Dispensing (Single Drug) & (All Drugs) ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
- +2 ;This routine places the IV data into files 58.8 and 58.81. It is called
- +3 ;by PSAPSI, PSAPSI2, AND PSAPSI3.
- +4 ;
- +5 NEW DIC,PSAD,PSAT
- +6 SET (PSA(4),PSA(6))=0
- FOR
- SET PSA(4)=$ORDER(^TMP("PSA",$JOB,PSADRUG,PSA(4)))
- IF 'PSA(4)
- QUIT
- SET PSA(6)=PSA(6)+1
- +7 ;get transaction numbers
- +8 FOR
- LOCK +^PSD(58.81,0):0
- IF $TEST
- QUIT
- FIND SET PSAD=$PIECE(^PSD(58.81,0),U,3)+1
- IF $DATA(^PSD(58.81,PSAD))
- SET $PIECE(^PSD(58.81,0),U,3)=$PIECE(^PSD(58.81,0),U,3)+1
- GOTO FIND
- +1 SET PSAT=PSAD
- SET DIC="^PSD(58.81,"
- SET DIC(0)="L"
- SET DLAYGO=58.81
- +2 FOR PSAD=PSAT:1:(PSAT+(PSA(6)-1))
- SET (DINUM,X)=PSAD
- DO ^DIC
- +3 LOCK -^PSD(58.81,0)
- KILL DIC,DINUM,DLAYGO
- +4 ;loop thru array
- LUP SET PSA(4)=0
- FOR
- SET PSA(4)=$ORDER(^TMP("PSA",$JOB,PSADRUG,PSA(4)))
- IF 'PSA(4)
- QUIT
- SET PSA=$GET(^TMP("PSA",$JOB,PSADRUG,PSA(4)))
- IF $PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,6)),U,4)
- SET PSA=PSA/$PIECE($GET(^(6)),U,4)
- DO LUP1
- +1 KILL ^TMP("PSA",$JOB,PSADRUG)
- +2 QUIT
- LUP1 ;get date + current balance + update balance
- +1 FOR
- LOCK +^PSD(58.8,PSALOC,1,PSADRUG,0):0
- IF $TEST
- QUIT
- +2 SET PSAB=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,0)),U,4)
- +3 IF '$GET(PSA(7))
- GOTO EDO
- +4 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRUG,0),U,4)=$PIECE($GET(^(0)),U,4)-PSA
- EDO LOCK -^PSD(58.8,PSALOC,1,PSADRUG,0)
- +1 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,0))
- SET ^(0)="^58.801A^^"
- +2 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,+$EXTRACT(PSA(4),1,5)*100,0))
- Begin DoDot:1
- +3 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
- SET DIC(0)="L"
- SET DIC("DR")="1////^S X=$G(PSAB)"
- SET (X,DINUM)=$EXTRACT(PSA(4),1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSADRUG
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC,DINUM,DLAYGO
- +4 SET X="T-1M"
- DO ^%DT
- SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
- SET DIC(0)="L"
- SET (X,DINUM)=$EXTRACT(Y,1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSADRUG
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC,DINUM,DLAYGO
- SET DA=+Y
- +5 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
- SET DA(2)=PSALOC
- SET DA(1)=PSADRUG
- +6 SET DR="3////^S X=$G(PSAB)"
- DO ^DIE
- KILL DIE
- End DoDot:1
- +7 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
- SET DR="9////^S X=$P($G(^(0)),U,6)+PSA"
- SET DA=$EXTRACT(PSA(4),1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSADRUG
- DO ^DIE
- KILL DA
- +8 ;update transaction
- +9 SET DIE="^PSD(58.81,"
- SET DR="1////15;2////^S X=PSALOC;3///^S X=PSA(4);4////^S X=PSADRUG;5////^S X=PSA;9////^S X=$G(PSAB)"
- SET DA=PSAT
- +10 DO ^DIE
- KILL DIE,DA,PSAB
- +11 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,4,0))
- SET ^(0)="^58.800119PA^^"
- +12 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",4,"
- SET DIC(0)="L"
- SET (X,DINUM)=PSAT
- +13 SET DA(2)=PSALOC
- SET DA(1)=PSADRUG
- SET DLAYGO=58.8
- DO ^DIC
- KILL DA,DIC,DINUM,DLAYGO
- +14 SET DIE="^PSD(58.8,"_PSALOC_",1,"
- SET DA(1)=PSALOC
- SET DA=PSADRUG
- SET DR="24////^S X=PSA(4)_"",""_$G(PSAW(1))"
- DO ^DIE
- SET PSAT=PSAT+1
- +15 QUIT
