- PSOUTLA ;BHAM ISC/AMC - pharmacy utility program ;07/24/96 1:13 pm
- ;;7.0;OUTPATIENT PHARMACY;**1,15,23,56,126,222,354,444,496,526**;DEC 1997;Build 3
- ;External reference ^PS(54 supported by DBIA 2227
- ;External reference ^PSDRUG( supported by DBIA 221
- CHK I '$D(PY(PSPR)) W !?10,$C(7)," # ",PSPR," is not a valid choice." S PSPOP=1 Q
- I $D(PSDUP(PY(PSPR))) W !?10,$C(7),"RX# ",$P(^PSRX(+$P(PY(PSPR),"^"),0),"^")," is a duplicate choice." S PSPOP=1 Q
- S PSDUP(PY(PSPR))="" Q:'PSODIV Q:'$P(^PSRX(+PY(PSPR),2),"^",9) Q:+$P(^(2),"^",9)=PSOSITE
- S PSPRXN=+$P(PY(PSPR),"^")
- CHK1 I '$P(PSOSYS,"^",2) W !!,$C(7),"RX# "_$P(^PSRX(PSPRXN,0),"^")_" is not a valid choice. (Different Division)",! S PSPOP=1 Q
- I $P(PSOSYS,"^",3) K DIR,DUOUT,DTOUT D
- .W $C(7) S DIR("A",1)="",DIR("A",2)="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is from another division.",DIR("A")="Continue: (Y/N)",DIR(0)="Y",DIR("?",1)="'Y' FOR YES",DIR("?")="'N' FOR NO"
- .S DIR("B")="N" D ^DIR I 'Y!($D(DUOUT))!($D(DTOUT)) S PSPOP=1 W !
- K DIR,DUOUT,DTOUT Q
- ;
- ZIPIN ; input transform for ZIP field in file #59 internal format (no '-'s)
- ; Input: X as user entered value
- ; Output: X as internal value of user input OR
- ; undefined if input from user was invalid
- N % I X'?.N F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,20),%=%-1
- I X'?5N,(X'?9N) K X
- Q
- ;
- ZIPOUT ; output transform for ZIP - prints either ZIP or ZIP+4 (in 12345-1234)
- ; format.
- ; Input: Y internal value
- ; Output: Y external (12345 or 12345-1234)
- S Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:"")
- Q
- YN ;YES/NO PROMPT
- W !?5,"'Y' FOR YES",!?5,"'N' FOR NO",!
- Q
- DAYS ;
- K PSFMAX S ED=1,PSODEA=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3),PSDAYS=$P(^PSRX(DA,0),"^",8),CS=0
- D EDNEW K:ED PSFMAX,ED K:$P(^PSRX(DA,0),"^",9)'>MAX PSMAX
- Q
- EDNEW ;
- K PSMAX,PSFMAX
- ; Retrieving the Maximum Number of Refills allowed
- S PSMAX=$$MAXNUMRF^PSOUTIL(+$P(^PSRX(DA,0),"^",6),PSDAYS,+$P(^PSRX(DA,0),"^",3),.CLOZPAT)
- ;
- I PSRF>PSMAX D
- .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_PSMAX_".",!
- K PSTMAX D EDSTAT
- Q
- STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
- EDSTAT I PSRF>PTRF D EN^DDIOL(PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.","","$C(7),!") D EN^DDIOL(" ","","!")
- Q
- PARKILL S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA(1),"A",SUB)) Q:'SUB S CNT=SUB
- I '$G(RESK) D G:$D(DIRUT) PARKILL
- .D EN^DDIOL(" ","","!") K DIR S DIR(0)="FO^10:75",DIR("A",1)="Enter Reason for Edit:",DIR("A")="=>",DIR("?",1)="This is a required response. No Up-arrowing allowed."
- .S DIR("?")="Response must be 10-75 characters in length.",DIR("B")="Entered In Error"
- .D ^DIR I $D(DIRUT) D EN^DDIOL("This is a required response. No Up-arrowing allowed.","","!") Q
- .S ACOM=$S($G(Y)]""&('$D(DIRUT)):Y,1:"Partial Entered In Error.")
- .S PSOPRZ=$G(PSOPRZ)-1 S:PSOPRZ<0 PSOPRZ=0
- S:$G(RESK) ACOM="Partial fill returned to stock."
- D NOW^%DTC S CNT=CNT+1 S ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT,^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^6^"_ACOM K CNT,SUB,DIR,DTOUT,DUOUT
- Q
- SETUP ;enter/edit clinic sort groups
- W ! S (DLAYGO,DIC,DIE)=59.8,DIC("A")="Select Clinic Sort Group: ",DIC(0)="AEQML" D ^DIC G:"^"[$E(X) SETUPX G:Y<1 SETUP S DA=+Y,DR=".01;1" D ^DIE
- SETUPX K DIE,DIC,DA,DLAYGO,Y,X,DR
- Q
- FSIG(PSOFILE,PSOINTR,PSOLENTH) ;Format front door sig
- ;PSOFILE is 'P' if in Pending File, 'R' if in Prescription File
- ;PSOINTR is internal number for either file
- ;PSOLENTH is length of each line of the Sig
- ;returned in the FSIG array
- K FSIG I $G(PSOFILE)=""!('$G(PSOINTR))!('$G(PSOLENTH)) G FQUIT
- I PSOFILE'="P",PSOFILE'="R" G FQUIT
- I PSOFILE="P",'$D(^PS(52.41,+PSOINTR,0)) G FQUIT
- I PSOFILE="R",'$D(^PSRX(+PSOINTR,0)) G FQUIT
- I PSOFILE="R",'$P($G(^PSRX(+PSOINTR,"SIG")),"^",2) G FQUIT
- N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
- I PSOFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSOINTR,"SIG",NNN)) Q:'NNN S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
- I PSOFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
- ;S HSIG(1)=$P($G(^PSRX(PSOINTR,"SIG")),"^") S FFF=2 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN I $G(^(NNN,0))'="" S HSIG(FFF)=$G(^(0)),FFF=FFF+1
- S FFF=1 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN I $G(^(NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
- G:'$O(HSIG(0)) FQUIT
- FSTART S (FVAR,FVAR1)="",II=1
- F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D I $L(FVAR)>PSOLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
- .S FVAR1=$P(HSIG(FFF)," ",(CNT))
- .S FLIM=FVAR
- .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
- I $G(FVAR)'="" S FSIG(II)=FVAR
- I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
- FQUIT Q
- DRUGW ;
- F Z0=1:1 Q:$P(X,",",Z0,99)="" S Z1=$P(X,",",Z0) W:$D(^PS(54,Z1,0)) ?35,$P(^(0),"^"),! I '$D(^(0)) W ?35,"NO SUCH WARNING LABEL" K X Q
- Q
- HLNEW ;formats provider instructions in FSIG for front door order
- K FSIG N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,LLP,PSOLENTH
- S PSOLENTH=59,LLP=1 F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL S HSIG(LLP)=$G(WPARRAY(7,LLL)),LLP=LLP+1
- D FSTART Q
- HLNEWX ;
- K FSIG N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,LLP,PSOLENTH
- S PSOLENTH=59,LLP=1 F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL S HSIG(LLP)=$G(WPARRAY(6,LLL)),LLP=LLP+1
- D FSTART Q
- ;
- SUSFDS ;
- N SUSIEN
- Q:$O(^PSRX(DA,1,0))
- S SUSIEN=+$O(^PS(52.5,"B",DA,0)) Q:'$G(SUSIEN)
- Q:'$D(^PS(52.5,SUSIEN,0))!($G(^PS(52.5,SUSIEN,"P")))
- I '$P($G(^PS(52.5,SUSIEN,0)),"^",5),'$P($G(^(0)),"^",13) S $P(^PS(52.5,SUSIEN,0),"^",2)=X,^PS(52.5,"C",X,SUSIEN)="" D
- .I $P($G(^PS(52.5,SUSIEN,0)),"^",7)="Q" S ^PS(52.5,"AQ",X,+$P($G(^PS(52.5,SUSIEN,0)),"^",3),SUSIEN)="" D SCMPX^PSOCMOP(SUSIEN,"Q") Q
- .S ^PS(52.5,"AC",+$P($G(^PS(52.5,SUSIEN,0)),"^",3),X,SUSIEN)=""
- Q
- SUSFDK ;
- N SUSIEN
- Q:$O(^PSRX(DA,1,0))
- S SUSIEN=+$O(^PS(52.5,"B",DA,0)) Q:'$G(SUSIEN)
- Q:'$D(^PS(52.5,SUSIEN,0))!($G(^PS(52.5,SUSIEN,"P")))
- I '$P($G(^PS(52.5,SUSIEN,0)),"^",5),'$P($G(^(0)),"^",13) K ^PS(52.5,"C",X,SUSIEN) D
- .I $P($G(^PS(52.5,SUSIEN,0)),"^",7)="Q" K ^PS(52.5,"AQ",X,+$P($G(^PS(52.5,SUSIEN,0)),"^",3),SUSIEN) D KCMPX^PSOCMOP(SUSIEN,"Q") Q
- .K ^PS(52.5,"AC",+$P($G(^PS(52.5,SUSIEN,0)),"^",3),X,SUSIEN)
- Q
- ADD ;enter/edit automated devices - OPAI
- W ! S (DLAYGO,DIC,DIE)=52.53,DIC("A")="Select ADD Name: ",DIC(0)="AEQML" D ^DIC G:"^"[$E(X) ADDX G:Y<1 ADD S DA=+Y,DR=".01;1;2;3" D ^DIE G ADD
- ADDX K DIE,DIC,DA,Y,X,DR
- Q
- ;
- FLDTINTR(FILLTYPE) ; Input Transform for FILL DATE, REFILL DATE and PARTIAL DATE fields in the PRESCRIPTION file (#52)
- ;Input Parameter: FILLTYPE - Prescription Fill Type: "O": Original, "R": Refill, "P": Partial
- ;Input Variables: X - Fill Date entered / DA/DA(1) - Pointer to the PRESCRIPTION file (#52)
- N RXIEN,%DT,Y
- I '$D(X) Q
- S RXIEN=+$S(FILLTYPE="O":$G(DA),1:$G(DA(1)))
- S %DT="EX" D ^%DT S X=Y I Y<1 D EN^DDIOL("INVALID DATE","","$C(7),!!?5") K X Q ;*526
- I '$D(^PSRX(RXIEN,0)) Q
- I $P(^PSRX(RXIEN,0),U,13),X<$P(^PSRX(RXIEN,0),U,13) D K X Q
- . D EN^DDIOL($S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be before ISSUE DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,0),U,13),"2Z")_")","","$C(7),!!?5")
- I '$D(^PSRX(RXIEN,2)) Q
- I $P(^PSRX(RXIEN,2),U,6),X>$P(^PSRX(RXIEN,2),U,6) D K X Q
- . D EN^DDIOL($S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be after EXPIRATION DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,2),U,6),"2Z")_")","","$C(7),!!?5")
- Q
- ;
- FLDTHELP(FILLTYPE) ; Executable Help for FILL DATE, REFILL DATE and PARTIAL DATE fields in the PRESCRIPTION file (#52)
- ;Input Parameter: FILLTYPE - Prescription Fill Type: "O": Original, "R": Refill, "P": Partial
- ;Input Variables: DA/DA(1) - Pointer to the PRESCRIPTION file (#52)
- N RXIEN
- S RXIEN=+$S(FILLTYPE="O":$G(DA),1:$G(DA(1)))
- I $P($G(^PSRX(RXIEN,0)),"^",13) D
- . D EN^DDIOL("The "_$S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be before ISSUE DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,0),U,13),"2Z")_")","","!")
- I $P($G(^PSRX(RXIEN,2)),"^",6) D
- . D EN^DDIOL("The "_$S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be after EXPIRATION DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,2),U,6),"2Z")_")","","!")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOUTLA 8446 printed Jan 18, 2025@03:37:14 Page 2
- PSOUTLA ;BHAM ISC/AMC - pharmacy utility program ;07/24/96 1:13 pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**1,15,23,56,126,222,354,444,496,526**;DEC 1997;Build 3
- +2 ;External reference ^PS(54 supported by DBIA 2227
- +3 ;External reference ^PSDRUG( supported by DBIA 221
- CHK IF '$DATA(PY(PSPR))
- WRITE !?10,$CHAR(7)," # ",PSPR," is not a valid choice."
- SET PSPOP=1
- QUIT
- +1 IF $DATA(PSDUP(PY(PSPR)))
- WRITE !?10,$CHAR(7),"RX# ",$PIECE(^PSRX(+$PIECE(PY(PSPR),"^"),0),"^")," is a duplicate choice."
- SET PSPOP=1
- QUIT
- +2 SET PSDUP(PY(PSPR))=""
- if 'PSODIV
- QUIT
- if '$PIECE(^PSRX(+PY(PSPR),2),"^",9)
- QUIT
- if +$PIECE(^(2),"^",9)=PSOSITE
- QUIT
- +3 SET PSPRXN=+$PIECE(PY(PSPR),"^")
- CHK1 IF '$PIECE(PSOSYS,"^",2)
- WRITE !!,$CHAR(7),"RX# "_$PIECE(^PSRX(PSPRXN,0),"^")_" is not a valid choice. (Different Division)",!
- SET PSPOP=1
- QUIT
- +1 IF $PIECE(PSOSYS,"^",3)
- KILL DIR,DUOUT,DTOUT
- Begin DoDot:1
- +2 WRITE $CHAR(7)
- SET DIR("A",1)=""
- SET DIR("A",2)="RX# "_$PIECE(^PSRX(PSPRXN,0),"^")_" is from another division."
- SET DIR("A")="Continue: (Y/N)"
- SET DIR(0)="Y"
- SET DIR("?",1)="'Y' FOR YES"
- SET DIR("?")="'N' FOR NO"
- +3 SET DIR("B")="N"
- DO ^DIR
- IF 'Y!($DATA(DUOUT))!($DATA(DTOUT))
- SET PSPOP=1
- WRITE !
- End DoDot:1
- +4 KILL DIR,DUOUT,DTOUT
- QUIT
- +5 ;
- ZIPIN ; input transform for ZIP field in file #59 internal format (no '-'s)
- +1 ; Input: X as user entered value
- +2 ; Output: X as internal value of user input OR
- +3 ; undefined if input from user was invalid
- +4 NEW %
- IF X'?.N
- FOR %=1:1:$LENGTH(X)
- IF $EXTRACT(X,%)?1P
- SET X=$EXTRACT(X,0,%-1)_$EXTRACT(X,%+1,20)
- SET %=%-1
- +5 IF X'?5N
- IF (X'?9N)
- KILL X
- +6 QUIT
- +7 ;
- ZIPOUT ; output transform for ZIP - prints either ZIP or ZIP+4 (in 12345-1234)
- +1 ; format.
- +2 ; Input: Y internal value
- +3 ; Output: Y external (12345 or 12345-1234)
- +4 SET Y=$EXTRACT(Y,1,5)_$SELECT($EXTRACT(Y,6,9)]"":"-"_$EXTRACT(Y,6,9),1:"")
- +5 QUIT
- YN ;YES/NO PROMPT
- +1 WRITE !?5,"'Y' FOR YES",!?5,"'N' FOR NO",!
- +2 QUIT
- DAYS ;
- +1 KILL PSFMAX
- SET ED=1
- SET PSODEA=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^",3)
- SET PSDAYS=$PIECE(^PSRX(DA,0),"^",8)
- SET CS=0
- +2 DO EDNEW
- if ED
- KILL PSFMAX,ED
- if $PIECE(^PSRX(DA,0),"^",9)'>MAX
- KILL PSMAX
- +3 QUIT
- EDNEW ;
- +1 KILL PSMAX,PSFMAX
- +2 ; Retrieving the Maximum Number of Refills allowed
- +3 SET PSMAX=$$MAXNUMRF^PSOUTIL(+$PIECE(^PSRX(DA,0),"^",6),PSDAYS,+$PIECE(^PSRX(DA,0),"^",3),.CLOZPAT)
- +4 ;
- +5 IF PSRF>PSMAX
- Begin DoDot:1
- +6 WRITE $CHAR(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_PSMAX_".",!
- End DoDot:1
- +7 KILL PSTMAX
- DO EDSTAT
- +8 QUIT
- STATDAY KILL PSMAX,PSRMAX,PSFMAX,PSTMAX
- SET PSDAYS=$PIECE(^PSRX(DA,0),"^",8)
- SET PSRF=$PIECE(^PSRX(DA,0),"^",9)
- SET PTST=$PIECE(^PS(53,X,0),"^")
- SET PTDY=$PIECE(^(0),"^",3)
- SET PTRF=$PIECE(^(0),"^",4)
- EDSTAT IF PSRF>PTRF
- DO EN^DDIOL(PSRF_" refills are greater than "_PTRF_" allowed for "_$PIECE(PTST,"^")_" Rx Patient Status.","","$C(7),!")
- DO EN^DDIOL(" ","","!")
- +1 QUIT
- PARKILL SET CNT=0
- FOR SUB=0:0
- SET SUB=$ORDER(^PSRX(DA(1),"A",SUB))
- if 'SUB
- QUIT
- SET CNT=SUB
- +1 IF '$GET(RESK)
- Begin DoDot:1
- +2 DO EN^DDIOL(" ","","!")
- KILL DIR
- SET DIR(0)="FO^10:75"
- SET DIR("A",1)="Enter Reason for Edit:"
- SET DIR("A")="=>"
- SET DIR("?",1)="This is a required response. No Up-arrowing allowed."
- +3 SET DIR("?")="Response must be 10-75 characters in length."
- SET DIR("B")="Entered In Error"
- +4 DO ^DIR
- IF $DATA(DIRUT)
- DO EN^DDIOL("This is a required response. No Up-arrowing allowed.","","!")
- QUIT
- +5 SET ACOM=$SELECT($GET(Y)]""&('$DATA(DIRUT)):Y,1:"Partial Entered In Error.")
- +6 SET PSOPRZ=$GET(PSOPRZ)-1
- if PSOPRZ<0
- SET PSOPRZ=0
- End DoDot:1
- if $DATA(DIRUT)
- GOTO PARKILL
- +7 if $GET(RESK)
- SET ACOM="Partial fill returned to stock."
- +8 DO NOW^%DTC
- SET CNT=CNT+1
- SET ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT
- SET ^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^6^"_ACOM
- KILL CNT,SUB,DIR,DTOUT,DUOUT
- +9 QUIT
- SETUP ;enter/edit clinic sort groups
- +1 WRITE !
- SET (DLAYGO,DIC,DIE)=59.8
- SET DIC("A")="Select Clinic Sort Group: "
- SET DIC(0)="AEQML"
- DO ^DIC
- if "^"[$EXTRACT(X)
- GOTO SETUPX
- if Y<1
- GOTO SETUP
- SET DA=+Y
- SET DR=".01;1"
- DO ^DIE
- SETUPX KILL DIE,DIC,DA,DLAYGO,Y,X,DR
- +1 QUIT
- FSIG(PSOFILE,PSOINTR,PSOLENTH) ;Format front door sig
- +1 ;PSOFILE is 'P' if in Pending File, 'R' if in Prescription File
- +2 ;PSOINTR is internal number for either file
- +3 ;PSOLENTH is length of each line of the Sig
- +4 ;returned in the FSIG array
- +5 KILL FSIG
- IF $GET(PSOFILE)=""!('$GET(PSOINTR))!('$GET(PSOLENTH))
- GOTO FQUIT
- +6 IF PSOFILE'="P"
- IF PSOFILE'="R"
- GOTO FQUIT
- +7 IF PSOFILE="P"
- IF '$DATA(^PS(52.41,+PSOINTR,0))
- GOTO FQUIT
- +8 IF PSOFILE="R"
- IF '$DATA(^PSRX(+PSOINTR,0))
- GOTO FQUIT
- +9 IF PSOFILE="R"
- IF '$PIECE($GET(^PSRX(+PSOINTR,"SIG")),"^",2)
- GOTO FQUIT
- +10 NEW FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
- +11 IF PSOFILE="P"
- FOR NNN=0:0
- SET NNN=$ORDER(^PS(52.41,PSOINTR,"SIG",NNN))
- if 'NNN
- QUIT
- if $GET(^(NNN,0))'=""
- SET HSIG(NNN)=^(0)
- +12 IF PSOFILE="P"
- if '$ORDER(HSIG(0))
- GOTO FQUIT
- GOTO FSTART
- +13 ;S HSIG(1)=$P($G(^PSRX(PSOINTR,"SIG")),"^") S FFF=2 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN I $G(^(NNN,0))'="" S HSIG(FFF)=$G(^(0)),FFF=FFF+1
- +14 SET FFF=1
- FOR NNN=0:0
- SET NNN=$ORDER(^PSRX(PSOINTR,"SIG1",NNN))
- if 'NNN
- QUIT
- IF $GET(^(NNN,0))'=""
- SET HSIG(FFF)=^(0)
- SET FFF=FFF+1
- +15 if '$ORDER(HSIG(0))
- GOTO FQUIT
- FSTART SET (FVAR,FVAR1)=""
- SET II=1
- +1 FOR FFF=0:0
- SET FFF=$ORDER(HSIG(FFF))
- if 'FFF
- QUIT
- SET CNT=0
- FOR NNN=1:1:$LENGTH(HSIG(FFF))
- IF $EXTRACT(HSIG(FFF),NNN)=" "!($LENGTH(HSIG(FFF))=NNN)
- SET CNT=CNT+1
- Begin DoDot:1
- +2 SET FVAR1=$PIECE(HSIG(FFF)," ",(CNT))
- +3 SET FLIM=FVAR
- +4 SET FVAR=$SELECT(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
- End DoDot:1
- IF $LENGTH(FVAR)>PSOLENTH
- SET FSIG(II)=FLIM_" "
- SET II=II+1
- SET FVAR=FVAR1
- +5 IF $GET(FVAR)'=""
- SET FSIG(II)=FVAR
- +6 IF $GET(FSIG(1))=""!($GET(FSIG(1))=" ")
- SET FSIG(1)=$GET(FSIG(2))
- KILL FSIG(2)
- FQUIT QUIT
- DRUGW ;
- +1 FOR Z0=1:1
- if $PIECE(X,",",Z0,99)=""
- QUIT
- SET Z1=$PIECE(X,",",Z0)
- if $DATA(^PS(54,Z1,0))
- WRITE ?35,$PIECE(^(0),"^"),!
- IF '$DATA(^(0))
- WRITE ?35,"NO SUCH WARNING LABEL"
- KILL X
- QUIT
- +2 QUIT
- HLNEW ;formats provider instructions in FSIG for front door order
- +1 KILL FSIG
- NEW FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,LLP,PSOLENTH
- +2 SET PSOLENTH=59
- SET LLP=1
- FOR LLL=0:0
- SET LLL=$ORDER(WPARRAY(7,LLL))
- if 'LLL
- QUIT
- SET HSIG(LLP)=$GET(WPARRAY(7,LLL))
- SET LLP=LLP+1
- +3 DO FSTART
- QUIT
- HLNEWX ;
- +1 KILL FSIG
- NEW FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,LLP,PSOLENTH
- +2 SET PSOLENTH=59
- SET LLP=1
- FOR LLL=0:0
- SET LLL=$ORDER(WPARRAY(6,LLL))
- if 'LLL
- QUIT
- SET HSIG(LLP)=$GET(WPARRAY(6,LLL))
- SET LLP=LLP+1
- +3 DO FSTART
- QUIT
- +4 ;
- SUSFDS ;
- +1 NEW SUSIEN
- +2 if $ORDER(^PSRX(DA,1,0))
- QUIT
- +3 SET SUSIEN=+$ORDER(^PS(52.5,"B",DA,0))
- if '$GET(SUSIEN)
- QUIT
- +4 if '$DATA(^PS(52.5,SUSIEN,0))!($GET(^PS(52.5,SUSIEN,"P")))
- QUIT
- +5 IF '$PIECE($GET(^PS(52.5,SUSIEN,0)),"^",5)
- IF '$PIECE($GET(^(0)),"^",13)
- SET $PIECE(^PS(52.5,SUSIEN,0),"^",2)=X
- SET ^PS(52.5,"C",X,SUSIEN)=""
- Begin DoDot:1
- +6 IF $PIECE($GET(^PS(52.5,SUSIEN,0)),"^",7)="Q"
- SET ^PS(52.5,"AQ",X,+$PIECE($GET(^PS(52.5,SUSIEN,0)),"^",3),SUSIEN)=""
- DO SCMPX^PSOCMOP(SUSIEN,"Q")
- QUIT
- +7 SET ^PS(52.5,"AC",+$PIECE($GET(^PS(52.5,SUSIEN,0)),"^",3),X,SUSIEN)=""
- End DoDot:1
- +8 QUIT
- SUSFDK ;
- +1 NEW SUSIEN
- +2 if $ORDER(^PSRX(DA,1,0))
- QUIT
- +3 SET SUSIEN=+$ORDER(^PS(52.5,"B",DA,0))
- if '$GET(SUSIEN)
- QUIT
- +4 if '$DATA(^PS(52.5,SUSIEN,0))!($GET(^PS(52.5,SUSIEN,"P")))
- QUIT
- +5 IF '$PIECE($GET(^PS(52.5,SUSIEN,0)),"^",5)
- IF '$PIECE($GET(^(0)),"^",13)
- KILL ^PS(52.5,"C",X,SUSIEN)
- Begin DoDot:1
- +6 IF $PIECE($GET(^PS(52.5,SUSIEN,0)),"^",7)="Q"
- KILL ^PS(52.5,"AQ",X,+$PIECE($GET(^PS(52.5,SUSIEN,0)),"^",3),SUSIEN)
- DO KCMPX^PSOCMOP(SUSIEN,"Q")
- QUIT
- +7 KILL ^PS(52.5,"AC",+$PIECE($GET(^PS(52.5,SUSIEN,0)),"^",3),X,SUSIEN)
- End DoDot:1
- +8 QUIT
- ADD ;enter/edit automated devices - OPAI
- +1 WRITE !
- SET (DLAYGO,DIC,DIE)=52.53
- SET DIC("A")="Select ADD Name: "
- SET DIC(0)="AEQML"
- DO ^DIC
- if "^"[$EXTRACT(X)
- GOTO ADDX
- if Y<1
- GOTO ADD
- SET DA=+Y
- SET DR=".01;1;2;3"
- DO ^DIE
- GOTO ADD
- ADDX KILL DIE,DIC,DA,Y,X,DR
- +1 QUIT
- +2 ;
- FLDTINTR(FILLTYPE) ; Input Transform for FILL DATE, REFILL DATE and PARTIAL DATE fields in the PRESCRIPTION file (#52)
- +1 ;Input Parameter: FILLTYPE - Prescription Fill Type: "O": Original, "R": Refill, "P": Partial
- +2 ;Input Variables: X - Fill Date entered / DA/DA(1) - Pointer to the PRESCRIPTION file (#52)
- +3 NEW RXIEN,%DT,Y
- +4 IF '$DATA(X)
- QUIT
- +5 SET RXIEN=+$SELECT(FILLTYPE="O":$GET(DA),1:$GET(DA(1)))
- +6 ;*526
- SET %DT="EX"
- DO ^%DT
- SET X=Y
- IF Y<1
- DO EN^DDIOL("INVALID DATE","","$C(7),!!?5")
- KILL X
- QUIT
- +7 IF '$DATA(^PSRX(RXIEN,0))
- QUIT
- +8 IF $PIECE(^PSRX(RXIEN,0),U,13)
- IF X<$PIECE(^PSRX(RXIEN,0),U,13)
- Begin DoDot:1
- +9 DO EN^DDIOL($SELECT(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be before ISSUE DATE ("_$$FMTE^XLFDT($PIECE(^PSRX(RXIEN,0),U,13),"2Z")_")","","$C(7),!!?5")
- End DoDot:1
- KILL X
- QUIT
- +10 IF '$DATA(^PSRX(RXIEN,2))
- QUIT
- +11 IF $PIECE(^PSRX(RXIEN,2),U,6)
- IF X>$PIECE(^PSRX(RXIEN,2),U,6)
- Begin DoDot:1
- +12 DO EN^DDIOL($SELECT(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be after EXPIRATION DATE ("_$$FMTE^XLFDT($PIECE(^PSRX(RXIEN,2),U,6),"2Z")_")","","$C(7),!!?5")
- End DoDot:1
- KILL X
- QUIT
- +13 QUIT
- +14 ;
- FLDTHELP(FILLTYPE) ; Executable Help for FILL DATE, REFILL DATE and PARTIAL DATE fields in the PRESCRIPTION file (#52)
- +1 ;Input Parameter: FILLTYPE - Prescription Fill Type: "O": Original, "R": Refill, "P": Partial
- +2 ;Input Variables: DA/DA(1) - Pointer to the PRESCRIPTION file (#52)
- +3 NEW RXIEN
- +4 SET RXIEN=+$SELECT(FILLTYPE="O":$GET(DA),1:$GET(DA(1)))
- +5 IF $PIECE($GET(^PSRX(RXIEN,0)),"^",13)
- Begin DoDot:1
- +6 DO EN^DDIOL("The "_$SELECT(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be before ISSUE DATE ("_$$FMTE^XLFDT($PIECE(^PSRX(RXIEN,0),U,13),"2Z")_")","","!")
- End DoDot:1
- +7 IF $PIECE($GET(^PSRX(RXIEN,2)),"^",6)
- Begin DoDot:1
- +8 DO EN^DDIOL("The "_$SELECT(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be after EXPIRATION DATE ("_$$FMTE^XLFDT($PIECE(^PSRX(RXIEN,2),U,6),"2Z")_")","","!")
- End DoDot:1
- +9 QUIT