- PXVTRAN ;ISP/LMT - Transfer Vaccine Inventory Between Facilities ;Dec 03, 2018@15:13:49
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**217**;Aug 12, 1996;Build 134
- ;
- ;
- EN(PXINST,PXTITLE) ;
- ;
- N PXADD,PXCONF,PXEXIT,PXVAC,PXQTY,PXTO
- ;
- I '$O(^AUTTIML("AF",PXINST,0)) D Q
- . W $C(7),!!,"There are no vaccine lots in the transferring facility.",!!
- . H 1
- ;
- F D Q:$G(PXEXIT)
- . W @IOF,?10,"Transfer Vaccine Inventory From "_PXTITLE,!
- . S PXVAC=$$VAC(PXINST)
- . I PXVAC<1 S PXEXIT=1 Q
- . S PXQTY=$$QTY(PXVAC)
- . I PXQTY=0 W ! Q
- . I PXQTY<0 S PXEXIT=1 Q
- . S PXTO=$$TO(PXINST)
- . I PXTO=0 W ! Q
- . I PXTO<0 S PXEXIT=1 Q
- . S PXADD=$$ADDCHK(PXVAC,PXTO)
- . I PXADD=0 W ! Q
- . I PXADD<0 S PXEXIT=1 Q
- . S PXCONF=$$CONF(PXVAC,PXQTY,PXINST,PXTO)
- . I PXCONF=0 W ! Q
- . I PXCONF<0 S PXEXIT=1 Q
- . D TRAN(PXVAC,PXQTY,PXTO,PXADD)
- ;
- Q
- ;
- VAC(PXINST) ;
- ;
- N DIC,DIDIC,DINUM,DLAYGO,X,Y,PXVAC,DTOUT,DUOUT
- ;
- S PXVAC=""
- ;
- W !
- S DIC("S")="I $P(^(0),""^"",10)="_PXINST_"&($P(^(0),""^"",9)'<DT)&('$P(^(0),""^"",3))"
- S DIC(0)="AEMQ"
- S DIC="^AUTTIML("
- D ^DIC
- I $D(DTOUT)!($D(DUOUT)) Q -1
- I Y<1 Q 0
- ;
- S PXVAC=+Y
- Q PXVAC
- ;
- QTY(PXVAC) ;
- ;
- N DIR,X,Y,PXBAL,PXQTY,DTOUT,DUOUT
- ;
- S PXBAL=$P($G(^AUTTIML(PXVAC,0)),U,12)
- ;
- I PXBAL'>0 D Q 0
- . W $C(7),!!,"This vaccine lot has a "_$S(PXBAL=0:"zero",1:"negative")_" balance."
- . W !,"Select another vaccine lot to transfer.",!
- . H 2
- ;
- W !!,?5,"Current Balance: "_PXBAL,!
- S DIR(0)="NO^1:"_PXBAL_":0"
- S DIR("A")="Enter Quantity to Transfer"
- S DIR("?",1)="Enter a whole number between 1 and "_PXBAL_"."
- S DIR("?")="This is the number of doses to transfer."
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) Q -1
- I Y<1 Q 0
- S PXQTY=+Y
- Q PXQTY
- ;
- TO(PXINST) ;
- ;
- N DIR,X,Y,PXTO,DTOUT,DUOUT
- ;
- ;S DIR(0)="9999999.41,.1"
- S DIR(0)="P^4:AEQM"
- S DIR("A")="Enter the facility name or station number"
- S DIR("S")="I Y'="_PXINST
- S DIR("?")="Enter the facility that will be receiving the vaccines."
- D ^DIR
- ;
- I $D(DTOUT)!($D(DUOUT)) Q -1
- I Y<1 Q 0
- ;
- S PXTO=+Y
- Q PXTO
- ;
- ADDCHK(PXVAC,PXTO) ;
- ;
- N DIR,X,Y,PXLN,PXVIM,PXMAN,PXVACTO,DTOUT,DUOUT
- ;
- S PXLN=$P($G(^AUTTIML(PXVAC,0)),U,1)
- S PXVIM=$P($G(^AUTTIML(PXVAC,0)),U,4)
- S PXMAN=$P($G(^AUTTIML(PXVAC,0)),U,2)
- I PXVIM=""!(PXMAN="") Q -1
- S PXVACTO=$O(^AUTTIML("AC",PXVIM,PXMAN,PXLN_"_#"_PXTO,0))
- I PXVACTO Q "0^"_PXVACTO
- ;
- W $C(7),!!,$P($$NS^XUAF4(PXTO),U)_" does not currently stock this lot!",!
- S DIR(0)="Y"
- S DIR("A")="Do you want to continue"
- S DIR("?",1)="Answer 'YES' to add this vaccine lot to the receiving facility."
- S DIR("?")="Answer 'NO' to quit this transfer request."
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) Q -1
- I Y<1 Q 0
- Q +Y
- ;
- CONF(PXVAC,PXQTY,PXINST,PXTO) ;
- ;
- N DIR,X,Y,PXLINE,PXLN,PXVIM,PXMAN,PXX,DTOUT,DUOUT
- ;
- S PXLN=$P($G(^AUTTIML(PXVAC,0)),U,1)
- S PXVIM=$$GET1^DIQ(9999999.41,PXVAC_",",.04)
- S PXMAN=$$GET1^DIQ(9999999.41,PXVAC_",",.02)
- ;
- S $P(PXLINE,"-",80)=""
- W @IOF,!,PXLINE
- W !,PXVIM
- W !,"Manufacturer: "_PXMAN
- W !,"Lot: "_PXLN
- W !,"Exp Date: "_$$FMTE^XLFDT($P($G(^AUTTIML(PXVAC,0)),U,9),"5D")
- W !!,"Transferring: "_PXQTY_" (Doses)"
- S PXX=$$NS^XUAF4(PXINST)
- W !!,"From: "_$P(PXX,U)_" ("_$P(PXX,U,2)_")"
- S PXX=$$NS^XUAF4(PXTO)
- W !,"To : "_$P(PXX,U)_" ("_$P(PXX,U,2)_")"
- W !,PXLINE,!
- S DIR(0)="Y"
- S DIR("A")="OK to post"
- S DIR("B")="Yes"
- S DIR("?")="Answer 'YES' to post this transfer, 'NO' to quit."
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) Q -1
- I Y<1 Q 0
- Q +Y
- ;
- TRAN(PXVAC,PXQTY,PXTO,PXADD) ;
- ;
- N PXFQTY,PXTQTY,PXVACTO,PXFDA
- ;
- W !!,"Updating vaccine on-hand balances now..."
- ;
- S PXFQTY=$P($G(^AUTTIML(PXVAC,0)),U,12)-PXQTY
- I PXFQTY<0 S PXFQTY=0
- S PXFDA(9999999.41,PXVAC_",",.12)=PXFQTY
- I PXADD D ADD(PXVAC,PXQTY,PXTO)
- I 'PXADD D
- . S PXVACTO=$P(PXADD,U,2)
- . S PXTQTY=$P($G(^AUTTIML(PXVACTO,0)),U,12)+PXQTY
- . S PXFDA(9999999.41,PXVACTO_",",.12)=PXTQTY
- ;
- D FILE^DIE("","PXFDA","PXERR")
- ;
- W !,"Done!",!
- H 1
- ;
- Q
- ;
- ADD(PXVAC,PXQTY,PXTO) ;
- ;
- N PXNODE,PXIENS,PXFDA
- ;
- S PXNODE=$G(^AUTTIML(PXVAC,0))
- S PXIENS="+1,"
- S PXFDA(1,9999999.41,PXIENS,.01)=$P(PXNODE,U,1)
- S PXFDA(1,9999999.41,PXIENS,.02)=$P(PXNODE,U,2)
- S PXFDA(1,9999999.41,PXIENS,.03)=$P(PXNODE,U,3)
- S PXFDA(1,9999999.41,PXIENS,.04)=$P(PXNODE,U,4)
- S PXFDA(1,9999999.41,PXIENS,.09)=$P(PXNODE,U,9)
- S PXFDA(1,9999999.41,PXIENS,.1)=PXTO
- S PXFDA(1,9999999.41,PXIENS,.11)=PXQTY
- S PXFDA(1,9999999.41,PXIENS,.12)=PXQTY
- S PXFDA(1,9999999.41,PXIENS,.15)=$P(PXNODE,U,15)
- S PXFDA(1,9999999.41,PXIENS,.18)=$P(PXNODE,U,18)
- ;
- D UPDATE^DIE("U","PXFDA(1)")
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVTRAN 4636 printed Feb 18, 2025@23:58:27 Page 2
- PXVTRAN ;ISP/LMT - Transfer Vaccine Inventory Between Facilities ;Dec 03, 2018@15:13:49
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**217**;Aug 12, 1996;Build 134
- +2 ;
- +3 ;
- EN(PXINST,PXTITLE) ;
- +1 ;
- +2 NEW PXADD,PXCONF,PXEXIT,PXVAC,PXQTY,PXTO
- +3 ;
- +4 IF '$ORDER(^AUTTIML("AF",PXINST,0))
- Begin DoDot:1
- +5 WRITE $CHAR(7),!!,"There are no vaccine lots in the transferring facility.",!!
- +6 HANG 1
- End DoDot:1
- QUIT
- +7 ;
- +8 FOR
- Begin DoDot:1
- +9 WRITE @IOF,?10,"Transfer Vaccine Inventory From "_PXTITLE,!
- +10 SET PXVAC=$$VAC(PXINST)
- +11 IF PXVAC<1
- SET PXEXIT=1
- QUIT
- +12 SET PXQTY=$$QTY(PXVAC)
- +13 IF PXQTY=0
- WRITE !
- QUIT
- +14 IF PXQTY<0
- SET PXEXIT=1
- QUIT
- +15 SET PXTO=$$TO(PXINST)
- +16 IF PXTO=0
- WRITE !
- QUIT
- +17 IF PXTO<0
- SET PXEXIT=1
- QUIT
- +18 SET PXADD=$$ADDCHK(PXVAC,PXTO)
- +19 IF PXADD=0
- WRITE !
- QUIT
- +20 IF PXADD<0
- SET PXEXIT=1
- QUIT
- +21 SET PXCONF=$$CONF(PXVAC,PXQTY,PXINST,PXTO)
- +22 IF PXCONF=0
- WRITE !
- QUIT
- +23 IF PXCONF<0
- SET PXEXIT=1
- QUIT
- +24 DO TRAN(PXVAC,PXQTY,PXTO,PXADD)
- End DoDot:1
- if $GET(PXEXIT)
- QUIT
- +25 ;
- +26 QUIT
- +27 ;
- VAC(PXINST) ;
- +1 ;
- +2 NEW DIC,DIDIC,DINUM,DLAYGO,X,Y,PXVAC,DTOUT,DUOUT
- +3 ;
- +4 SET PXVAC=""
- +5 ;
- +6 WRITE !
- +7 SET DIC("S")="I $P(^(0),""^"",10)="_PXINST_"&($P(^(0),""^"",9)'<DT)&('$P(^(0),""^"",3))"
- +8 SET DIC(0)="AEMQ"
- +9 SET DIC="^AUTTIML("
- +10 DO ^DIC
- +11 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT -1
- +12 IF Y<1
- QUIT 0
- +13 ;
- +14 SET PXVAC=+Y
- +15 QUIT PXVAC
- +16 ;
- QTY(PXVAC) ;
- +1 ;
- +2 NEW DIR,X,Y,PXBAL,PXQTY,DTOUT,DUOUT
- +3 ;
- +4 SET PXBAL=$PIECE($GET(^AUTTIML(PXVAC,0)),U,12)
- +5 ;
- +6 IF PXBAL'>0
- Begin DoDot:1
- +7 WRITE $CHAR(7),!!,"This vaccine lot has a "_$SELECT(PXBAL=0:"zero",1:"negative")_" balance."
- +8 WRITE !,"Select another vaccine lot to transfer.",!
- +9 HANG 2
- End DoDot:1
- QUIT 0
- +10 ;
- +11 WRITE !!,?5,"Current Balance: "_PXBAL,!
- +12 SET DIR(0)="NO^1:"_PXBAL_":0"
- +13 SET DIR("A")="Enter Quantity to Transfer"
- +14 SET DIR("?",1)="Enter a whole number between 1 and "_PXBAL_"."
- +15 SET DIR("?")="This is the number of doses to transfer."
- +16 DO ^DIR
- +17 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT -1
- +18 IF Y<1
- QUIT 0
- +19 SET PXQTY=+Y
- +20 QUIT PXQTY
- +21 ;
- TO(PXINST) ;
- +1 ;
- +2 NEW DIR,X,Y,PXTO,DTOUT,DUOUT
- +3 ;
- +4 ;S DIR(0)="9999999.41,.1"
- +5 SET DIR(0)="P^4:AEQM"
- +6 SET DIR("A")="Enter the facility name or station number"
- +7 SET DIR("S")="I Y'="_PXINST
- +8 SET DIR("?")="Enter the facility that will be receiving the vaccines."
- +9 DO ^DIR
- +10 ;
- +11 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT -1
- +12 IF Y<1
- QUIT 0
- +13 ;
- +14 SET PXTO=+Y
- +15 QUIT PXTO
- +16 ;
- ADDCHK(PXVAC,PXTO) ;
- +1 ;
- +2 NEW DIR,X,Y,PXLN,PXVIM,PXMAN,PXVACTO,DTOUT,DUOUT
- +3 ;
- +4 SET PXLN=$PIECE($GET(^AUTTIML(PXVAC,0)),U,1)
- +5 SET PXVIM=$PIECE($GET(^AUTTIML(PXVAC,0)),U,4)
- +6 SET PXMAN=$PIECE($GET(^AUTTIML(PXVAC,0)),U,2)
- +7 IF PXVIM=""!(PXMAN="")
- QUIT -1
- +8 SET PXVACTO=$ORDER(^AUTTIML("AC",PXVIM,PXMAN,PXLN_"_#"_PXTO,0))
- +9 IF PXVACTO
- QUIT "0^"_PXVACTO
- +10 ;
- +11 WRITE $CHAR(7),!!,$PIECE($$NS^XUAF4(PXTO),U)_" does not currently stock this lot!",!
- +12 SET DIR(0)="Y"
- +13 SET DIR("A")="Do you want to continue"
- +14 SET DIR("?",1)="Answer 'YES' to add this vaccine lot to the receiving facility."
- +15 SET DIR("?")="Answer 'NO' to quit this transfer request."
- +16 DO ^DIR
- +17 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT -1
- +18 IF Y<1
- QUIT 0
- +19 QUIT +Y
- +20 ;
- CONF(PXVAC,PXQTY,PXINST,PXTO) ;
- +1 ;
- +2 NEW DIR,X,Y,PXLINE,PXLN,PXVIM,PXMAN,PXX,DTOUT,DUOUT
- +3 ;
- +4 SET PXLN=$PIECE($GET(^AUTTIML(PXVAC,0)),U,1)
- +5 SET PXVIM=$$GET1^DIQ(9999999.41,PXVAC_",",.04)
- +6 SET PXMAN=$$GET1^DIQ(9999999.41,PXVAC_",",.02)
- +7 ;
- +8 SET $PIECE(PXLINE,"-",80)=""
- +9 WRITE @IOF,!,PXLINE
- +10 WRITE !,PXVIM
- +11 WRITE !,"Manufacturer: "_PXMAN
- +12 WRITE !,"Lot: "_PXLN
- +13 WRITE !,"Exp Date: "_$$FMTE^XLFDT($PIECE($GET(^AUTTIML(PXVAC,0)),U,9),"5D")
- +14 WRITE !!,"Transferring: "_PXQTY_" (Doses)"
- +15 SET PXX=$$NS^XUAF4(PXINST)
- +16 WRITE !!,"From: "_$PIECE(PXX,U)_" ("_$PIECE(PXX,U,2)_")"
- +17 SET PXX=$$NS^XUAF4(PXTO)
- +18 WRITE !,"To : "_$PIECE(PXX,U)_" ("_$PIECE(PXX,U,2)_")"
- +19 WRITE !,PXLINE,!
- +20 SET DIR(0)="Y"
- +21 SET DIR("A")="OK to post"
- +22 SET DIR("B")="Yes"
- +23 SET DIR("?")="Answer 'YES' to post this transfer, 'NO' to quit."
- +24 DO ^DIR
- +25 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT -1
- +26 IF Y<1
- QUIT 0
- +27 QUIT +Y
- +28 ;
- TRAN(PXVAC,PXQTY,PXTO,PXADD) ;
- +1 ;
- +2 NEW PXFQTY,PXTQTY,PXVACTO,PXFDA
- +3 ;
- +4 WRITE !!,"Updating vaccine on-hand balances now..."
- +5 ;
- +6 SET PXFQTY=$PIECE($GET(^AUTTIML(PXVAC,0)),U,12)-PXQTY
- +7 IF PXFQTY<0
- SET PXFQTY=0
- +8 SET PXFDA(9999999.41,PXVAC_",",.12)=PXFQTY
- +9 IF PXADD
- DO ADD(PXVAC,PXQTY,PXTO)
- +10 IF 'PXADD
- Begin DoDot:1
- +11 SET PXVACTO=$PIECE(PXADD,U,2)
- +12 SET PXTQTY=$PIECE($GET(^AUTTIML(PXVACTO,0)),U,12)+PXQTY
- +13 SET PXFDA(9999999.41,PXVACTO_",",.12)=PXTQTY
- End DoDot:1
- +14 ;
- +15 DO FILE^DIE("","PXFDA","PXERR")
- +16 ;
- +17 WRITE !,"Done!",!
- +18 HANG 1
- +19 ;
- +20 QUIT
- +21 ;
- ADD(PXVAC,PXQTY,PXTO) ;
- +1 ;
- +2 NEW PXNODE,PXIENS,PXFDA
- +3 ;
- +4 SET PXNODE=$GET(^AUTTIML(PXVAC,0))
- +5 SET PXIENS="+1,"
- +6 SET PXFDA(1,9999999.41,PXIENS,.01)=$PIECE(PXNODE,U,1)
- +7 SET PXFDA(1,9999999.41,PXIENS,.02)=$PIECE(PXNODE,U,2)
- +8 SET PXFDA(1,9999999.41,PXIENS,.03)=$PIECE(PXNODE,U,3)
- +9 SET PXFDA(1,9999999.41,PXIENS,.04)=$PIECE(PXNODE,U,4)
- +10 SET PXFDA(1,9999999.41,PXIENS,.09)=$PIECE(PXNODE,U,9)
- +11 SET PXFDA(1,9999999.41,PXIENS,.1)=PXTO
- +12 SET PXFDA(1,9999999.41,PXIENS,.11)=PXQTY
- +13 SET PXFDA(1,9999999.41,PXIENS,.12)=PXQTY
- +14 SET PXFDA(1,9999999.41,PXIENS,.15)=$PIECE(PXNODE,U,15)
- +15 SET PXFDA(1,9999999.41,PXIENS,.18)=$PIECE(PXNODE,U,18)
- +16 ;
- +17 DO UPDATE^DIE("U","PXFDA(1)")
- +18 ;
- +19 QUIT