PSOUTLA ;BHAM ISC/AMC - pharmacy utility program ;06-Dec-2012 19:59;PLS
;;7.0;OUTPATIENT PHARMACY;**1,15,23,56,126,222,1015**;DEC 1997;Build 62
;External reference ^PS(54 supported by DBIA 2227
;External reference ^PSDRUG( supported by DBIA 221
;
; Modified - IHS/MSC/PLS - 12/06/2012 - Line EDNEW+7
;
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 F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&(PSDAYS=14):1,CLOZPAT=2&(PSDAYS=7):3,CLOZPAT=1&(PSDAYS=7):1,1:0) G CLOZPAT
I CS D
.S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
.S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
E D
.S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
.;IHS/MSC/PLS - 12/06/2012
.;S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
.S PSDY1=$S(PSDAYS<60:15,PSDAYS<90:5,PSDAYS=90:3,PSDAYS<168:2,PSDAYS<365:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
CLOZPAT I PSRF>MAX 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 "_MAX_".",!
.;S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1
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(" ","","!") ;S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^")
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
PSOUTLA ;BHAM ISC/AMC - pharmacy utility program ;06-Dec-2012 19:59;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**1,15,23,56,126,222,1015**;DEC 1997;Build 62
+2 ;External reference ^PS(54 supported by DBIA 2227
+3 ;External reference ^PSDRUG( supported by DBIA 221
+4 ;
+5 ; Modified - IHS/MSC/PLS - 12/06/2012 - Line EDNEW+7
+6 ;
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 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
DO EDNEW
IF ED
KILL PSFMAX,ED
+1 IF $PIECE(^PSRX(DA,0),"^",9)'>MAX
KILL PSMAX
+2 QUIT
EDNEW KILL PSMAX,PSFMAX
FOR DEA=1:1
IF $EXTRACT(PSODEA,DEA)=""
QUIT
IF $EXTRACT(+PSODEA,DEA)>1
IF $EXTRACT(+PSODEA,DEA)<6
SET CS=1
+1 IF $DATA(CLOZPAT)
SET MAX=$SELECT(CLOZPAT=2&(PSDAYS=14):1,CLOZPAT=2&(PSDAYS=7):3,CLOZPAT=1&(PSDAYS=7):1,1:0)
GOTO CLOZPAT
+2 IF CS
Begin DoDot:1
+3 SET PSOX1=$SELECT(PTRF>5:5,1:PTRF)
SET PSOX=$SELECT(PSOX1=5:5,1:PSOX1)
+4 SET PSOX=$SELECT('PSOX:0,PSDAYS=90:1,1:PSOX)
SET PSDY1=$SELECT(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
SET MAX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET PSOX1=PTRF
SET PSOX=$SELECT(PSOX1=11:11,1:PSOX1)
SET PSOX=$SELECT('PSOX:0,PSDAYS=90:3,1:PSOX)
+7 ;IHS/MSC/PLS - 12/06/2012
+8 ;S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
+9 SET PSDY1=$SELECT(PSDAYS<60:15,PSDAYS<90:5,PSDAYS=90:3,PSDAYS<168:2,PSDAYS<365:1,1:0)
SET MAX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)
End DoDot:1
CLOZPAT IF PSRF>MAX
Begin DoDot:1
+1 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 "_MAX_".",!
+2 ;S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1
End DoDot:1
+3 KILL PSTMAX
DO EDSTAT
+4 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 ;S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^")
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
