- PSOSITED ;BHAM ISC/SAB - ENTER/EDIT OUTPATIENT SITE PARAMETERS ; 09/18/92 9:11
- ;;7.0;OUTPATIENT PHARMACY;**24,65,268,354,452**;DEC 1997;Build 56
- ;External reference to ^PS(59.7 supported by DBIA 694
- I $G(PSOPAR)']"" D ^PSOLSET
- 1 W ! K DIC S DIC("A")="Select SITE NAME: ",(DIC,DIE)="^PS(59,",DIC(0)="QEALM",DLAYGO=59
- K PSOSITEX D ^DIC G:"^"[X EX K DIC("A") G:Y<0 1 S DA=+Y D FLDQ G:$D(PSOSITEX) EX S DR="[PSO SITE]" W ! D ^DIE K DIE("NO^")
- ;rtw added field 48 to DR below
- W !!,"Outpatient System Parameters",! S DA=1,DIE=59.7,DR="40;40.1;40.19;40.14;40.15;48" L +^PS(59.7,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Another person is editing this entry. Try Later!",! K DA,DIE,DR G 1
- D ^DIE L -^PS(59.7,DA)
- N CNT,TOT S (TOT,CNT)=0 F S CNT=$O(^PS(59,CNT)) Q:'CNT S TOT=TOT+1
- D:TOT>1 ^PSODIV K CNT,TOT
- S:$G(PSOSITE)=DA PSOPAR=$G(^PS(59,DA,1)),PSOPAR7=$G(^PS(59,DA,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D EX G 1
- EX K DIC,DA,DIE,DIR,DIV,DR,I,PS1,PS11,PSIX,PSOCNT,PSOSITEX,X,Y,%,%X,%Y,D0,DI,DQ,DX,S Q
- Q
- FLDQ S DIR("?",1)="Press <RETURN> if you want to see a list of all outpatient",DIR("?")="pharmacy answered site fields. Enter 'N' if you don't want to see the list."
- S DIR(0)="Y",DIR("A")="Would you like to see all site parameters for this division",DIR("B")="Y" D ^DIR K DIR S:$D(DTOUT) PSOSITEX="" I Y,'$D(PSOSITEX) W @IOF D EN^DIQ
- K DIR Q
- ;
- CATVAL(X) ;Input transform for CATEGORY field #1, OPAI sub-file #59.20081
- ;of the DISPENSING SYSTEM PRINTER sub-file #59.02008 of File #59.
- ;This check ensures that a dispensing printer is not assigned more
- ;than one ADD device with conflicting categories which guarantees an
- ;RX is routed to only one dispensing device. Valid category
- ;combinations are shown at the COMB line tag. Category "A"ny is
- ;selectable only when no other category is defined on file for that
- ;device and vice versa. The category "S"torage can be combined with
- ;any other category or can standalone.
- ;
- I $G(X)="" Q 0
- N DEV,CAT,CATL,FLG,II,XX
- S (DEV,FLG)=0,CATL=""
- F S DEV=$O(^PS(59,DA(2),"P",DA(1),"OPAI",DEV)) Q:'DEV D I FLG Q
- .S CAT=$P($G(^PS(59,DA(2),"P",DA(1),"OPAI",DEV,0)),"^",2) I CAT="" Q
- .I DEV=DA Q ;current entry
- .I CAT'="S",X=CAT D EN^DDIOL(" <-- Category already on file.","","?0") S FLG=1 Q
- .S CATL=CATL_"^"_CAT
- I FLG Q FLG
- ;if no categories are on file or the category entered is storage then quit
- I (CATL="")!(X="S") Q FLG
- S CATL=CATL_"^"_X
- F II=1:1 S XX=$T(COMB+II) Q:XX["END" S XX=$P(XX,";;",2),FLG=$$COMCHK(XX,CATL) I 'FLG Q
- I FLG D
- .;D EN^DDIOL(" <-- Can't be combined with categories on file.","","?0")
- .D EN^DDIOL(" <-- Conflicting categories.","","?0")
- .D EN^DDIOL("*** Valid category combinations are:","","!?5")
- .F II=1:1 S XX=$T(COMB+II) Q:XX["END" S XX=$P(XX,";;",2) D
- ..S XX=$E(XX,2,9999)
- ..D EN^DDIOL(II_". "_$TR(XX,"^",", "),"","!?8")
- .D EN^DDIOL(" ","","?0")
- Q FLG
- ;
- COMCHK(CMBO,STR) ; check allowable ADD combinations for a printer
- ;INPUT CMBO - contains a set of categories that can be combined together
- ; STR - checked against CMBO for validity.
- ;OUTPUT - returns a 0 if a combination is valid, else a 1.
- ;
- N I1,VAL,FLG
- S FLG=0
- ;find valid CMBO combination base on value in STR
- F I1=1:1:$L(STR,"^") S VAL=$P(STR,"^",I1) D I FLG Q
- .I VAL'="",VAL'="S",CMBO'[("^"_VAL_"^") S FLG=1
- Q FLG
- ;
- COMB ; valid category combinations for ADDs that can be assigned to a dispensing printer.
- ;;^MCS^MNCS^WCS^WNCS^S
- ;;^MCS^MNCS^WIND^S
- ;;^WCS^WNCS^MAIL^S
- ;;^CS^MNCS^WNCS^S
- ;;^NCS^WCS^MCS^S
- ;;^MAIL^WIND^S
- ;;^CS^NCS^S
- ;;^A^S
- ;;^S
- ;;END
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSITED 3651 printed Feb 19, 2025@00:01:22 Page 2
- PSOSITED ;BHAM ISC/SAB - ENTER/EDIT OUTPATIENT SITE PARAMETERS ; 09/18/92 9:11
- +1 ;;7.0;OUTPATIENT PHARMACY;**24,65,268,354,452**;DEC 1997;Build 56
- +2 ;External reference to ^PS(59.7 supported by DBIA 694
- +3 IF $GET(PSOPAR)']""
- DO ^PSOLSET
- 1 WRITE !
- KILL DIC
- SET DIC("A")="Select SITE NAME: "
- SET (DIC,DIE)="^PS(59,"
- SET DIC(0)="QEALM"
- SET DLAYGO=59
- +1 KILL PSOSITEX
- DO ^DIC
- if "^"[X
- GOTO EX
- KILL DIC("A")
- if Y<0
- GOTO 1
- SET DA=+Y
- DO FLDQ
- if $DATA(PSOSITEX)
- GOTO EX
- SET DR="[PSO SITE]"
- WRITE !
- DO ^DIE
- KILL DIE("NO^")
- +2 ;rtw added field 48 to DR below
- +3 WRITE !!,"Outpatient System Parameters",!
- SET DA=1
- SET DIE=59.7
- SET DR="40;40.1;40.19;40.14;40.15;48"
- LOCK +^PS(59.7,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
- IF '$TEST
- WRITE !,"Another person is editing this entry. Try Later!",!
- KILL DA,DIE,DR
- GOTO 1
- +4 DO ^DIE
- LOCK -^PS(59.7,DA)
- +5 NEW CNT,TOT
- SET (TOT,CNT)=0
- FOR
- SET CNT=$ORDER(^PS(59,CNT))
- if 'CNT
- QUIT
- SET TOT=TOT+1
- +6 if TOT>1
- DO ^PSODIV
- KILL CNT,TOT
- +7 if $GET(PSOSITE)=DA
- SET PSOPAR=$GET(^PS(59,DA,1))
- SET PSOPAR7=$GET(^PS(59,DA,"IB"))
- SET PSOSYS=$GET(^PS(59.7,1,40.1))
- DO EX
- GOTO 1
- EX KILL DIC,DA,DIE,DIR,DIV,DR,I,PS1,PS11,PSIX,PSOCNT,PSOSITEX,X,Y,%,%X,%Y,D0,DI,DQ,DX,S
- QUIT
- +1 QUIT
- FLDQ SET DIR("?",1)="Press <RETURN> if you want to see a list of all outpatient"
- SET DIR("?")="pharmacy answered site fields. Enter 'N' if you don't want to see the list."
- +1 SET DIR(0)="Y"
- SET DIR("A")="Would you like to see all site parameters for this division"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- if $DATA(DTOUT)
- SET PSOSITEX=""
- IF Y
- IF '$DATA(PSOSITEX)
- WRITE @IOF
- DO EN^DIQ
- +2 KILL DIR
- QUIT
- +3 ;
- CATVAL(X) ;Input transform for CATEGORY field #1, OPAI sub-file #59.20081
- +1 ;of the DISPENSING SYSTEM PRINTER sub-file #59.02008 of File #59.
- +2 ;This check ensures that a dispensing printer is not assigned more
- +3 ;than one ADD device with conflicting categories which guarantees an
- +4 ;RX is routed to only one dispensing device. Valid category
- +5 ;combinations are shown at the COMB line tag. Category "A"ny is
- +6 ;selectable only when no other category is defined on file for that
- +7 ;device and vice versa. The category "S"torage can be combined with
- +8 ;any other category or can standalone.
- +9 ;
- +10 IF $GET(X)=""
- QUIT 0
- +11 NEW DEV,CAT,CATL,FLG,II,XX
- +12 SET (DEV,FLG)=0
- SET CATL=""
- +13 FOR
- SET DEV=$ORDER(^PS(59,DA(2),"P",DA(1),"OPAI",DEV))
- if 'DEV
- QUIT
- Begin DoDot:1
- +14 SET CAT=$PIECE($GET(^PS(59,DA(2),"P",DA(1),"OPAI",DEV,0)),"^",2)
- IF CAT=""
- QUIT
- +15 ;current entry
- IF DEV=DA
- QUIT
- +16 IF CAT'="S"
- IF X=CAT
- DO EN^DDIOL(" <-- Category already on file.","","?0")
- SET FLG=1
- QUIT
- +17 SET CATL=CATL_"^"_CAT
- End DoDot:1
- IF FLG
- QUIT
- +18 IF FLG
- QUIT FLG
- +19 ;if no categories are on file or the category entered is storage then quit
- +20 IF (CATL="")!(X="S")
- QUIT FLG
- +21 SET CATL=CATL_"^"_X
- +22 FOR II=1:1
- SET XX=$TEXT(COMB+II)
- if XX["END"
- QUIT
- SET XX=$PIECE(XX,";;",2)
- SET FLG=$$COMCHK(XX,CATL)
- IF 'FLG
- QUIT
- +23 IF FLG
- Begin DoDot:1
- +24 ;D EN^DDIOL(" <-- Can't be combined with categories on file.","","?0")
- +25 DO EN^DDIOL(" <-- Conflicting categories.","","?0")
- +26 DO EN^DDIOL("*** Valid category combinations are:","","!?5")
- +27 FOR II=1:1
- SET XX=$TEXT(COMB+II)
- if XX["END"
- QUIT
- SET XX=$PIECE(XX,";;",2)
- Begin DoDot:2
- +28 SET XX=$EXTRACT(XX,2,9999)
- +29 DO EN^DDIOL(II_". "_$TRANSLATE(XX,"^",", "),"","!?8")
- End DoDot:2
- +30 DO EN^DDIOL(" ","","?0")
- End DoDot:1
- +31 QUIT FLG
- +32 ;
- COMCHK(CMBO,STR) ; check allowable ADD combinations for a printer
- +1 ;INPUT CMBO - contains a set of categories that can be combined together
- +2 ; STR - checked against CMBO for validity.
- +3 ;OUTPUT - returns a 0 if a combination is valid, else a 1.
- +4 ;
- +5 NEW I1,VAL,FLG
- +6 SET FLG=0
- +7 ;find valid CMBO combination base on value in STR
- +8 FOR I1=1:1:$LENGTH(STR,"^")
- SET VAL=$PIECE(STR,"^",I1)
- Begin DoDot:1
- +9 IF VAL'=""
- IF VAL'="S"
- IF CMBO'[("^"_VAL_"^")
- SET FLG=1
- End DoDot:1
- IF FLG
- QUIT
- +10 QUIT FLG
- +11 ;
- COMB ; valid category combinations for ADDs that can be assigned to a dispensing printer.
- +1 ;;^MCS^MNCS^WCS^WNCS^S
- +2 ;;^MCS^MNCS^WIND^S
- +3 ;;^WCS^WNCS^MAIL^S
- +4 ;;^CS^MNCS^WNCS^S
- +5 ;;^NCS^WCS^MCS^S
- +6 ;;^MAIL^WIND^S
- +7 ;;^CS^NCS^S
- +8 ;;^A^S
- +9 ;;^S
- +10 ;;END
