- PSADA ;BIR/LTL-Pharmacy Location Lookup Utility ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
- ;This routine is called by many routines. It is used to allow the user
- ;to select a pharmacy location.
- ;
- START D DT^DICRW N D,DIC,DIR,DIRUT,DTOUT,DUOUT,PSA,PSAB,PSAC,PSADRUG,PSAII,PSAIT,PSAIPS,PSAINV,PSAISIT,PSAOC,PSAOSIT,PSASTO,PSAITY,PSAOP,PSAO,PSAI,PSAOU,X,Y
- S PSALOC(1)=$O(^PSD(58.8,"ADISP","P",0))
- I 'PSALOC(1) W !,"No Drug Accountability location has been created yet.",! G QUIT
- ;only one
- I '$O(^PSD(58.8,"ADISP","P",+PSALOC(1))) S PSALOC=PSALOC(1),PSALOC(1)=0
- I $G(PSALOC) S PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U),PSAISIT=$P($G(^(0)),U,3),PSAOSIT=$P($G(^(0)),U,10) G QUIT
- ;pick type
- PIC S DIR(0)="S^1:INPATIENT;2:OUTPATIENT;3:COMBINED (IP/OP)",DIR("A")="Select Pharmacy type",PSALOC(1)=0 D ^DIR K DIR S:'Y PSAOUT=1,PSALOC=0 G:'Y QUIT
- S PSAITY=+Y,PSALOCN=Y(0)
- SKIP I PSAITY'=2 D
- .;check for more than one IP site
- .S (PSA(1),PSA(2))=0 F S PSA(1)=$O(^PS(59.4,PSA(1))) Q:'PSA(1) S:$P($G(^(PSA(1),0)),U,26)=1 PSA(2)=PSA(2)+1,PSAB=PSA(1)
- .I PSA(2)<1 W !!,"An Inpatient Site has not been identified for AR/WS.",!,"AR/WS dispensing data may not be gathered.",! S:PSAITY=3 PSAO=1 Q
- .S:PSA(2)=1 PSAISIT=PSAB
- .D:PSA(2)>1 I Y<1 S PSAOU=1 K PSALOC Q
- ..W !!,"Because there is more than one Inpatient Site at this facility, I need you to"
- ..S DIC="^PS(59.4,",DIC(0)="AEMQZ",DIC("A")="select an AR/WS Inpatient Site Name: ",DIC("S")="I $P($G(^(0)),U,26)=1" D ^DIC K DIC S:$D(DUOUT)!($D(DTOUT)) PSAOU=1 S:PSAITY=3&(Y<1) PSAO=1 Q:Y<1 S PSAISIT=+Y
- .S PSALOC=$O(^PSD(58.8,"ASITE",PSAISIT,"P",""))
- .I 'PSALOC S:PSAITY=3 PSAO=1 Q
- .I PSALOC S PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U) D:$O(^PSD(58.8,+PSALOC,3,0))
- ..W !!,"Checking wards for accurate collection of UD/IV dispensing.",!
- ..N PSAWARD S PSAWARD=0 F S PSAWARD=$O(^DIC(42,PSAWARD)) Q:'PSAWARD W "*" D:'$O(^PSD(58.8,"AB",+PSAWARD,0))&('$D(^DIC(42,+PSAWARD,"I")))
- ...W !!,$P($G(^DIC(42,+PSAWARD,0)),U)," is an active ward and NOT linked to any location."
- S:PSAITY>1 PSAO=1 G @$S($D(PSAOU):"QUIT",$D(PSAO):"OP",1:"QUIT")
- OP S Y=1,PSA=$O(^PS(59,0)) D:$O(^PS(59,PSA)) G:Y<0 QUIT
- .;more than one OP site
- .W !!,"Because there is more than one Outpatient Site at this facility, I need you to "
- .S DIC="^PS(59,",DIC(0)="AEMQ",DIC("A")="select an Outpatient Site: " D ^DIC K DIC S PSAOSIT=+Y
- S:'$D(PSAOSIT) PSAOSIT=PSA
- S PSALOC=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U)
- I $G(PSAOSIT),'$G(PSALOC) W !!,"No Drug Accountability location has been created for ",$P($G(^PS(59,+PSAOSIT,0)),U),".",!
- QUIT I '$G(PSALOC) W !,"No site was selected.",! Q
- I $G(PSALOC) S PSACNT=0 W !!,PSALOCN," for " D
- .I $P($G(^PS(59.4,+$G(PSAISIT),0)),U)'="" W $P(^(0),U)_" (IP) " S PSACNT=PSACNT+1
- .I $P($G(^PS(59,+$G(PSAOSIT),0)),U)'="" W $P(^(0),U)_" (OP)" S PSACNT=PSACNT+1
- .I 'PSACNT W "...I'm not sure"
- I $G(PSALOC(1)) S DIR(0)="Y",DIR("A")="OK",DIR("B")="Yes",DIR("?")="Answering no will allow you to change Location." D ^DIR K DIR K:Y=0 PSAOSIT,PSAISIT,PSALOC G:Y=0 PIC K:$D(DIRUT) PSALOC
- Q
- COP I '$O(^PSD(58.8,"AOP",0)) W !,"No outpatient sites have been set up.",! Q
- S PSALOC=$O(^PSD(58.8,"AOP",0)),PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U)
- Q:'$O(^PSD(58.8,"AOP",+PSALOC))
- W !!,"Because there is more than one Outpatient Site at this facility, I need you to "
- S DIC="^PSD(58.8,",DIC(0)="AEMQ",DIC("A")="select an Outpatient Site: ",D="AOP" D MIX^DIC1 S PSALOC=+Y,PSALOCN=$P($G(^PSD(58.8,+Y,0)),U)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADA 3554 printed Feb 18, 2025@23:15:29 Page 2
- PSADA ;BIR/LTL-Pharmacy Location Lookup Utility ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
- +2 ;This routine is called by many routines. It is used to allow the user
- +3 ;to select a pharmacy location.
- +4 ;
- START DO DT^DICRW
- NEW D,DIC,DIR,DIRUT,DTOUT,DUOUT,PSA,PSAB,PSAC,PSADRUG,PSAII,PSAIT,PSAIPS,PSAINV,PSAISIT,PSAOC,PSAOSIT,PSASTO,PSAITY,PSAOP,PSAO,PSAI,PSAOU,X,Y
- +1 SET PSALOC(1)=$ORDER(^PSD(58.8,"ADISP","P",0))
- +2 IF 'PSALOC(1)
- WRITE !,"No Drug Accountability location has been created yet.",!
- GOTO QUIT
- +3 ;only one
- +4 IF '$ORDER(^PSD(58.8,"ADISP","P",+PSALOC(1)))
- SET PSALOC=PSALOC(1)
- SET PSALOC(1)=0
- +5 IF $GET(PSALOC)
- SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
- SET PSAISIT=$PIECE($GET(^(0)),U,3)
- SET PSAOSIT=$PIECE($GET(^(0)),U,10)
- GOTO QUIT
- +6 ;pick type
- PIC SET DIR(0)="S^1:INPATIENT;2:OUTPATIENT;3:COMBINED (IP/OP)"
- SET DIR("A")="Select Pharmacy type"
- SET PSALOC(1)=0
- DO ^DIR
- KILL DIR
- if 'Y
- SET PSAOUT=1
- SET PSALOC=0
- if 'Y
- GOTO QUIT
- +1 SET PSAITY=+Y
- SET PSALOCN=Y(0)
- SKIP IF PSAITY'=2
- Begin DoDot:1
- +1 ;check for more than one IP site
- +2 SET (PSA(1),PSA(2))=0
- FOR
- SET PSA(1)=$ORDER(^PS(59.4,PSA(1)))
- if 'PSA(1)
- QUIT
- if $PIECE($GET(^(PSA(1),0)),U,26)=1
- SET PSA(2)=PSA(2)+1
- SET PSAB=PSA(1)
- +3 IF PSA(2)<1
- WRITE !!,"An Inpatient Site has not been identified for AR/WS.",!,"AR/WS dispensing data may not be gathered.",!
- if PSAITY=3
- SET PSAO=1
- QUIT
- +4 if PSA(2)=1
- SET PSAISIT=PSAB
- +5 if PSA(2)>1
- Begin DoDot:2
- +6 WRITE !!,"Because there is more than one Inpatient Site at this facility, I need you to"
- +7 SET DIC="^PS(59.4,"
- SET DIC(0)="AEMQZ"
- SET DIC("A")="select an AR/WS Inpatient Site Name: "
- SET DIC("S")="I $P($G(^(0)),U,26)=1"
- DO ^DIC
- KILL DIC
- if $DATA(DUOUT)!($DATA(DTOUT))
- SET PSAOU=1
- if PSAITY=3&(Y<1)
- SET PSAO=1
- if Y<1
- QUIT
- SET PSAISIT=+Y
- End DoDot:2
- IF Y<1
- SET PSAOU=1
- KILL PSALOC
- QUIT
- +8 SET PSALOC=$ORDER(^PSD(58.8,"ASITE",PSAISIT,"P",""))
- +9 IF 'PSALOC
- if PSAITY=3
- SET PSAO=1
- QUIT
- +10 IF PSALOC
- SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
- if $ORDER(^PSD(58.8,+PSALOC,3,0))
- Begin DoDot:2
- +11 WRITE !!,"Checking wards for accurate collection of UD/IV dispensing.",!
- +12 NEW PSAWARD
- SET PSAWARD=0
- FOR
- SET PSAWARD=$ORDER(^DIC(42,PSAWARD))
- if 'PSAWARD
- QUIT
- WRITE "*"
- if '$ORDER(^PSD(58.8,"AB",+PSAWARD,0))&('$DATA(^DIC(42,+PSAWARD,"I")))
- Begin DoDot:3
- +13 WRITE !!,$PIECE($GET(^DIC(42,+PSAWARD,0)),U)," is an active ward and NOT linked to any location."
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +14 if PSAITY>1
- SET PSAO=1
- GOTO @$SELECT($DATA(PSAOU):"QUIT",$DATA(PSAO):"OP",1:"QUIT")
- OP SET Y=1
- SET PSA=$ORDER(^PS(59,0))
- if $ORDER(^PS(59,PSA))
- Begin DoDot:1
- +1 ;more than one OP site
- +2 WRITE !!,"Because there is more than one Outpatient Site at this facility, I need you to "
- +3 SET DIC="^PS(59,"
- SET DIC(0)="AEMQ"
- SET DIC("A")="select an Outpatient Site: "
- DO ^DIC
- KILL DIC
- SET PSAOSIT=+Y
- End DoDot:1
- if Y<0
- GOTO QUIT
- +4 if '$DATA(PSAOSIT)
- SET PSAOSIT=PSA
- +5 SET PSALOC=$ORDER(^PSD(58.8,"AOP",+PSAOSIT,""))
- SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
- +6 IF $GET(PSAOSIT)
- IF '$GET(PSALOC)
- WRITE !!,"No Drug Accountability location has been created for ",$PIECE($GET(^PS(59,+PSAOSIT,0)),U),".",!
- QUIT IF '$GET(PSALOC)
- WRITE !,"No site was selected.",!
- QUIT
- +1 IF $GET(PSALOC)
- SET PSACNT=0
- WRITE !!,PSALOCN," for "
- Begin DoDot:1
- +2 IF $PIECE($GET(^PS(59.4,+$GET(PSAISIT),0)),U)'=""
- WRITE $PIECE(^(0),U)_" (IP) "
- SET PSACNT=PSACNT+1
- +3 IF $PIECE($GET(^PS(59,+$GET(PSAOSIT),0)),U)'=""
- WRITE $PIECE(^(0),U)_" (OP)"
- SET PSACNT=PSACNT+1
- +4 IF 'PSACNT
- WRITE "...I'm not sure"
- End DoDot:1
- +5 IF $GET(PSALOC(1))
- SET DIR(0)="Y"
- SET DIR("A")="OK"
- SET DIR("B")="Yes"
- SET DIR("?")="Answering no will allow you to change Location."
- DO ^DIR
- KILL DIR
- if Y=0
- KILL PSAOSIT,PSAISIT,PSALOC
- if Y=0
- GOTO PIC
- if $DATA(DIRUT)
- KILL PSALOC
- +6 QUIT
- COP IF '$ORDER(^PSD(58.8,"AOP",0))
- WRITE !,"No outpatient sites have been set up.",!
- QUIT
- +1 SET PSALOC=$ORDER(^PSD(58.8,"AOP",0))
- SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
- +2 if '$ORDER(^PSD(58.8,"AOP",+PSALOC))
- QUIT
- +3 WRITE !!,"Because there is more than one Outpatient Site at this facility, I need you to "
- +4 SET DIC="^PSD(58.8,"
- SET DIC(0)="AEMQ"
- SET DIC("A")="select an Outpatient Site: "
- SET D="AOP"
- DO MIX^DIC1
- SET PSALOC=+Y
- SET PSALOCN=$PIECE($GET(^PSD(58.8,+Y,0)),U)
- +5 QUIT