APSQCK ;IHS/ASDS/ENM/POC - CALLS TO NON FORMULARY REQUEST [ 11/20/2001 2:36 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;**3,4**;FEB 20, 2001
;PROGRAM FOR ALL CALLS TO NON FORMULARY REQUEST [ 01/24/2001 1:02 PM ]
;CALLS FROM PSORXDL PSON52 PSORN52 ROUTINES
;A XREF LOOKUP TO KEEP PROVIDER FROM GIVING SAME DRUG TO SAME PERSON ON SAME DAY OR HAVE A RECORD OPEN FOR PATIENT AND A SAME DRUG
;D EN^XBVK("APSQC")
Q
CK ;EP
D CK^APSQCK1 ;CONTINUE IN APSQCK
Q
LOOK ;EP LOOK UP AN ENTRY AND DO SOMETHING
;S LOOK TO PRINT TO PRINT OR XMB TO SEND MESSAGE
D LOOK^APSQCK1 ;CONTINUED IN APSQCK1
Q
;
APROV ;EP ENTRY POINT TO APPROVE NON FORMULARY REQUEST
W @IOF
W !!!
I '+($G(^VA(200,DUZ,"PS"))) W !,"YOU DON'T HAVE AUTHORIZATION TO WRITE MED ORDERS SO-BYE" G EXIT
W "ENTER YOUR ELECTRONIC SIGNATURE TO APPROVE A NON FORMULARY REQUESTS"
D SIG^XUSESIG
I X1="" W @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!" G EXIT
APROVA S:'$D(DUZSAVE) DUZSAVE=DUZ,DUZ=0 ;MOVE THIS BACK ON EXIT ACTION OF MENU
K FROM,HIT
;REQUESTING PROVIDER MUST BE FILLED IN AND APPROVING PROVIDER MUST BE NULL OR DUZ P/T MUST NOT HAVE SIGNATURE
;S FROM="",SCR="I $P(^(0),U,11)]"""",$S($P(^(1),U,2)="""":1,1:$P(^(1),U,2)=DUZSAVE)"
S FROM="",SCR="I $P(^(0),U,11)]"""",$S($P(^(1),U,2)="""":1,1:$P(^(1),U,2)=DUZSAVE),$P(^(1),U,4)="""""
D LIST1
;I '$D(HIT) G EXIT
G:$D(EXIT) EXIT G:'$D(HIT) APROVA
FROMA W @IOF
K DIC,DR
S DA=HIT,DIC="^APSQNF(",DIQ(0)="C"
D EN^DIQ
K DIR
S:$P(^APSQNF(HIT,1),U,2)]"" DEL=1
S DIR("A")="DO YOU WANT TO "_$S($D(DEL):"DELETE",1:"APPLY")_" YOUR ELECTRONIC SIGNATURE TO NON FORMULARY REQUEST "_$P(^APSQNF(HIT,0),U)
S DIR(0)="Y"
D ^DIR K DR,DIC
;I Y'=1 G EXIT
;I Y'=1 G APROVA
I (Y'=1),($D(RPROV)) K RPROV Q ;MEANS I CAME FROM RPROV AND GO BACK
I Y'=1 G APROVA
I ($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) G EXIT
S DIE="^APSQNF(",DA=HIT
I $D(DEL) S DR="5///@"
E S DR="5///`"_$S($D(DUZSAVE):DUZSAVE,1:DUZ)
D ^DIE
I '$D(Y) W !,"YOUR SIGNATURE HAS BEEN "_$S($D(DEL):"DELETED",1:"APPLIED") H 2
;PUT THESE LINES IN ***
I $G(HIT),'$D(DEL) D
.S:$P(^APSQNF(HIT,0),U,11) PERSON($P(^(0),U,11))="" ;REQUESTING PROVIDER
.S:$P(^APSQNF(HIT,1),U,2) PERSON($P(^(1),U,2))="" ;APPROVING PROVIDER
.;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
.D BULL(HIT,"APSQ NF APPROVING BULLETIN",.PERSON)
.K DEL
.Q
K HIT,DEL
I $D(RPROV) K RPROV Q ;IF COME FROM RPROV WANT TO GO BACK
G APROVA
;D EXIT
Q
PHAR ;EP ENTRY POINT TO EDIT NON FORMULARY REQUEST BY A PHARMACIST
W @IOF
W !!!
I '$D(^XUSEC("PSORPH",DUZ)) W !,"YOU MUST HAVE THE 'PSORPH' KEY TO CONTINUE-BYE" G EXIT
W "ENTER YOUR ELECTRONIC SIGNATURE TO EDIT NON FORMULARY REQUESTS"
D SIG^XUSESIG
I X1="" W @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!" G EXIT
PHARA I '$D(DUZSAVE) S DUZSAVE=DUZ,DUZ=0
;
;LIST NON FORMULARY REQUEST BY RPH
K FROM
;SCREEN IS MUST HAVE REQUESTING AND APPROVING PROVIDER,RPH MUST BE NULL OR DUZ, P/T MUST NOT HAVE SIGNED
S FROM="",SCR="I $P(^(0),U,11)]"""",$P(^(1),U,2)]"""",$S($P(^(1),U,4)="""":1,1:$P(^(1),U,4)=DUZSAVE),$P(^(1),U,6)="""""
D LIST1,EDIT1
I $G(Y)'="^" G PHARA ;**** GOTO
;F D LIST1,EDIT1 Q:$D(DTOUT)
Q
PTPROV ;EP ENTRY POINT TO ADD/EDIT NON FORMULARY REQUEST
W @IOF
W !!!
I '$D(^XUSEC("PSORPH",DUZ)) W !,"YOU MUST HAVE THE 'PSORPH' KEY TO CONTINUE-BYE" G EXIT
W "ENTER YOUR ELECTRONIC SIGNATURE TO ADD/EDIT NON FORMULARY REQUESTS"
D SIG^XUSESIG
I X1="" W @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!" G EXIT
PTPROVA I '$D(DUZSAVE) S DUZSAVE=DUZ,DUZ=0
;
;LIST NON FORMULARY REQUEST BY REQ PROVIDER WITH APP PROVIDER=""
K FROM
S FROM=""
;RREQUESTING PROVIDER, APPROVING PROVIDER, RPH MUST NOT BE NULL AND PT REVIEWER MUST BE NULL OR DUZ
S SCR="I $P(^(0),U,11)]"""",$P(^(1),U,2)]"""",$P(^(1),U,4)]"""",$S($P(^(1),U,6)="""":1,1:$P(^(1),U,6)=DUZSAVE)"
D LIST1,EDIT2
I $G(Y)'="^" G PTPROVA
Q
RPROV ;EP ENTRY POINT TO ADD/EDIT NON FORMULARY REQUEST
;THIS ENTRY POINT HAS THE REAL DUZ ONLY
W @IOF
W !!!
I '+($G(^VA(200,DUZ,"PS"))) W !,"YOU DON'T HAVE AUTHORIZATION TO WRITE MED ORDERS SO-BYE" G EXIT
W "ENTER YOUR ELECTRONIC SIGNATURE TO ADD/EDIT NON FORMULARY REQUESTS"
D SIG^XUSESIG
I X1="" W @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!" G EXIT
;
RPROVA ;LIST NON FORMULARY REQUEST BY REQ PROVIDER WITH APP PROVIDER=""
K FROM
;REQUESTING PROVIDER MUST BE DUZ AND APPROVING PROVIDER MUST BE NULL
;S FROM="",SCR="I $P(^(0),U,11)=DUZ,$P(^(1),U,2)="""""
S FROM="",SCR="I $P(^(0),U,11)=DUZ,$P(^(1),U,2)="""",$$PASS^APSQCK($P(^(0),U,11))"
;S FROM="",SCR="I 1"
;D LIST1,EDIT
D LIST1
G:$D(EXIT) EXIT
D EDIT
G:$D(EXIT) EXIT
;I $D(^XUSEC("APSQ NF APPROVING PROVIDER",DUZ)) D I %=1 S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE S RPROV=1 D APROVA
;.W !,"WOULD YOU LIKE TO APPROVE THE NON FORMULARY REQUEST ALSO SINCE YOU HAVE THE KEY"
;.S %=1 D YN^DICN
;G:$D(EXIT) EXIT
;I $G(Y)'="^" G RPROVA
G RPROVA
Q
LIST1 K OUT,DISP
D LIST^DIC(9009035.1,"",".01;1;2;3","B",3,.FROM,"","DT","X SCR","","OUT","ERR")
W @IOF,!
S NUM=+OUT("DILIST",0),MORE=$P(OUT("DILIST",0),U,3)
S CNT=0
S SEQ="" F S SEQ=$O(OUT("DILIST",1,SEQ),-1) Q:SEQ="" D
.S CNT=CNT+1
.S IEN=OUT("DILIST",2,SEQ)
.S DISP(CNT,"IEN")=IEN
.S DISP(CNT)="#"_CNT_":"
.S I="" F S I=$O(OUT("DILIST","ID",SEQ,I)) Q:I="" D
..S DISP(CNT)=DISP(CNT)_" "_OUT("DILIST","ID",SEQ,I)
F I=1:1 Q:'$D(DISP(I)) S DISP(I)=$E(DISP(I),1,75) W !,DISP(I)
;K DISP,OUT
DIR ;
S DIR(0)="NO^1:"_NUM
S DIR("A")="ENTER A NUMBER TO EDIT OR '^' TO EDIT NONE"
D ^DIR K DIR
;I $D(DTOUT)!(Y="^") S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE G EXIT ;*****
I $D(DTOUT)!(Y="^") S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE S EXIT=1 Q ;*****
;G:$D(DTOUT)!(Y<1) EXIT ;****GOTO
;I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) G EXIT
I Y="",MORE K I,J,IEN,DISP G LIST1 ;888888
;I Y="" K I,J,IEN,DISP G LIST1
I +Y S HIT=DISP(+Y,"IEN")
K Y,DIR
Q
EDIT2 ;EDIT A SCREEN FORM USING IEN FOR DA
I $D(DUZSAVE) S DUZ=DUZSAVE K DUZSAVE
I $D(HIT) S DA=HIT,ADD=0 ;K HIT
;E D ADD S ADD=1
G:$D(EXIT) EXIT
S DDSFILE=9009035.1
S DR="[APSQ NF PT]"
S DDSPARM="CES"
D ^DDS
;WANT TO DELETE IF ADDED BUT NOT SAVED
;IF $D(DDSAVE) THEN FORM WAS SAVED
;I '$D(DDSAVE),ADD S DA=HIT,DIK="^APSQNF(" D ^DIK K HIT,DA,DIK
;D ^ZTER
I $G(HIT),$D(DDSSAVE),$D(DDSCHANG) D
.S:$P(^APSQNF(HIT,0),U,11) PERSON($P(^(0),U,11))="" ;REQUESTING PROVIDER
.S:$P(^APSQNF(HIT,1),U,6) PERSON($P(^(1),U,6))="" ;PHARMACIST
.;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
.D BULL(HIT,"APSQ NF REQUESTING BULLETIN",.PERSON)
.Q
;D ^ZTER
K HIT
D EXIT
Q
EDIT1 ;EDIT A SCREEN FORM USING IEN FOR DA
I $D(DUZSAVE) S DUZ=DUZSAVE K DUZSAVE
I $D(HIT) S DA=HIT,ADD=0 ;K HIT
;E D ADD S ADD=1
G:$D(EXIT) EXIT
S DDSFILE=9009035.1
S DR="[APSQ NF PHARMACIST]"
S DDSPARM="CES"
D ^DDS
;WANT TO DELETE IF ADDED BUT NOT SAVED
;IF $D(DDSSAVE) THEN FORM WAS SAVED
;I '$D(DDSSAVE),ADD S DA=HIT,DIK="^APSQNF(" D ^DIK K HIT,DA,DIK
;D ^ZTER
I $G(HIT),$D(DDSSAVE),$D(DDSCHANG) D
.S:$P(^APSQNF(HIT,0),U,11) PERSON($P(^(0),U,11))="" ;REQUESTING PROVIDER
.S:$P(^APSQNF(HIT,1),U,4) PERSON($P(^(1),U,4))="" ;PHARMACIST
.;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
.D BULL(HIT,"APSQ NF REQUESTING BULLETIN",.PERSON)
.Q
;D ^ZTER
K HIT
D EXIT
Q
EDIT ;EDIT A SCREEN FORM USING IEN FOR DA
I $D(HIT) S DA=HIT,ADD=0 ;K HIT
E D ADD S ADD=1
;G:$D(EXIT) EXIT
;Q:$D(EXIT1) ;NOTE THIS IS EXIT1
I $D(EXIT1) K EXIT1 Q ;IHS/OKCAO/POC 6/5/2001
S DDSFILE=9009035.1
S DR="[APSQ NF REQUEST]"
S DDSPARM="CES"
D ^DDS
;I $D(DDSCHANG) W "IT WAS CHANGED" S ^PAT("CHANGED")=1 ;***
;IF $D(KILL) I DELETED FORM ENTRY THRU VALIDATION OF FORM
;I KILL K KILL G EXIT
I $D(KILL) K KILL G EXIT ;IHS/ITSC/ENM 11/20/2001
;WANT TO DELETE IF ADDED BUT NOT SAVED
;IF $D(DDSSAVE) THEN FORM WAS SAVED
I '$D(DDSSAVE),ADD S DA=HIT,DIK="^APSQNF(" D ^DIK K HIT,DA,DIK
I $G(HIT) S:$P(^APSQNF(HIT,0),U,11) PERSON($P(^(0),U,11))="" ;REQUESTING PROVIDER
;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
I $D(DDSSAVE),$D(DDSCHANG) D BULL(HIT,"APSQ NF REQUESTING BULLETIN",.PERSON)
;I $D(^XUSEC("APSQ NF APPROVING PROVIDER",DUZ)) D I %=1 S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE S RPROV=1 D FROMA
I ($D(^XUSEC("APSQ NF APPROVING PROVIDER",DUZ)))&($G(HIT)) D I %=1 S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE S RPROV=1 D:$G(HIT) FROMA ;IHS/OKCAO/POC 6/4/2001
.W !,"WOULD YOU LIKE TO APPROVE THE NON FORMULARY REQUEST ALSO SINCE YOU HAVE THE KEY"
.S %=1 D YN^DICN
K HIT
D EXIT
Q
ADD ;CALL DIC TO ADD AND THEN DDS TO EDIT
S DIR(0)="Y",DIR("A")="DO YOU WANT TO ENTER A NEW NON FORMULARY REQUEST",DIR("B")="NO" D ^DIR K DIR
IF Y'=1 S EXIT1=1 ;NOTE IT'S EXIT1
;Q:$D(EXIT1)
I $D(EXIT1) K EXIT1 Q ;IHS/OKCAO/POC 6/5/2001
S DIC="^APSQNF(",DIC(0)="LMNO"
S X=$O(^APSQNF("9999999999"),-1)+1,X=""""_X_""""
D ^DIC
I Y<1 W !,"SOMETHING WRONG DID NOT ADD ENTRY" S EXIT=1 Q ;G EXIT
S (HIT,DA)=+Y
Q
;
EXIT ;CLEAN UP TIME
I $D(DUZSAVE) S DUZ=DUZSAVE K DUZSAVE
K EXIT
K EXIT1 ;IHS/OKCAO/POC 6/5/2001
K OUT,DISP
K DDSPARM,DDSFILE,DR,DA,DDSSAVE,DDSCHANG
K ADD,CNT,PERSON,NUM,MORE,SCR,SEQ,IEN,I,FROM,GET,DEL,HIT
;K ADD,CNT,PERSON,NUM,MORE,SCR,SEQ,IEN,I,GET,DEL,HIT
K XMB,XMDUZ
Q
VAL1 ;EP CALLED FROM SCREENMAN UPON VALIDATING THE FORM APSQ NF PHARMACIST
;I MIGHT NOT USE THIS
D VAL1^APSQCK1 ;CONTINUED IN APSQCK1
Q
VAL2 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE FORM
D VAL2^APSQCK1 ;CONTINUED IN APSQCK1
Q
VAL3 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
D VAL3^APSQCK1 ;CONTINUE IN APSQCK1
Q
VAL33 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
D VAL33^APSQCK1 ;CONTINUE IN APSQCK1
Q
VAL4 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
D VAL4^APSQCK1 ;CONTINUE IN APSQCK1
Q
VAL44 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
D VAL44^APSQCK1 ;CONTINUE IN APSQCK1
Q
BULL(GOTIT,BULLETIN,XMY) ;SEND A BULLETIN GOTIT IS THE IEN OF APSQNF( AND BULLETIN IS NAME OF BULLETIN
;GOTIT IS THE IEN OF NONFORMULARY REQUEST
;BULLETIN IS NAME OF BULLETIN TO USE
;WHO IS ADDITIONAL PERSON TO SEND BULLETIN TO
W !!,"BULLETIN BEING SENT",!!
;S GOTIT="SOMETHING"
S GOTIT="`"_GOTIT ;WANT IEN I THINK
D FIND^DIC(9009035.1,,".01;2;3;4;4.1;5;5.1;6;6.1;7;7.1;7.5",,GOTIT,,,,,"GET","OUCH")
M XMB=GET("DILIST","ID",1) ;MAKE IT EASIER TO WORK WITH
D BULL2
D BULL1
Q
BULL1 S XMDUZ=.5
S XMB=BULLETIN
D ^XMB
K XMY
Q
;
BULL2 ;ADD ANY EXTRA PEOPLE TO BULLETIN
W !,"ADDITIONAL ENTRIES MAY BE ADDED TO THE BULLETIN"
W !,"REMEMBER ENTRIES HAVE BEEN ADDED FOR YOURSELF AND THE BULLETIN MAILGROUPS"
DIC S DIC(0)="AEMQ"
S DIC="^VA(200,"
S DIC("S")="I ($P(^(0),U,3)'="""")&($S($P(^(0),U,11)]"""":$P(^(0),U,11),1:9999999)>DT)"
S DIC("A")="ADDITIONAL 'LOCAL USER' TO THE BULLETIN //"
D ^DIC
I Y>0 S XMY(+Y)="" G DIC
K DIC
Q
S XMZ=$$FIND1^DIC(3.6,"","MX",BULLETIN)
S XMDUZ=.5
S XMDUN=""
D DEST^XMA21
;GETS XMY ARRAY
;W !,"SOME STUFF HERE"
Q
PASS(PROV) ;EP CHECK IF THIS IS A VALID NEW PERSON TO LOOK AT THIS ENTRY
Q:'$G(PROV) 1
;PROV WOULD BE THE REQUESTING PROVIDER. WOULD TAKE THIS PROV
;AND LOOK IN A NEW FILE WITH WHO CAN SIGN OFF AT VARIOUS STAGES
;CHECK WHO CAN SIGN OFF AGAINST DUZ
;AND RETURN THE QUIT VALUE AS 1 OR 0
Q 1
;
PRINT ;PRINT OR BROWSE A NON FORMULARY REQUEST
K DIR
S DIR(0)="SO^P:PRINT NON FORMULARY REQUEST;B:BROWSE NON FORMULARY REQUST"
S DIR("A")="DO YOU WANT TO "
S DIR("B")="PRINT"
W !
D ^DIR
K DIR
Q:($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) ;CHECK THIS ***
I $E($G(X))="P" D PRT Q
I $E($G(X))="B" D BROWSE Q
Q
BROWSE ; BROWSE IT
;NEED ENTRY XB... IN LIST TEMPLATE FILE
S TOP="NON FORMULARY REQUEST FOR "_$P(^DPT($P(^APSQNF(DA,0),U,3),0),U)
;D VIEWR^XBLM("EN^DIQ","NON FORMULARY REQUEST FOR "_TOP)
D VIEWR^XBLM("PRT1^APSQCK","NON FORMULARY REQUEST FOR "_TOP)
Q
;
PRT ;PRINT IT
S %ZIS="QM" D ^%ZIS G EXIT:POP
I $D(IO("Q")) D D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q
.S ZTRTN="PRT1^APSQCK",ZTDESC="PRINT OF ONE NON FORMULARY REQUEST"
PRT1 ;EP
S (END,NUMPT,PAGE)=0
U IO
D @("HDR"_(2-($E(IOST,1,2)="C-")))
S ARRAY=0 F S ARRAY=$O(ARRAY(ARRAY)) Q:ARRAY=""!END D
.W !,ARRAY(ARRAY)
.I ($Y+5)>IOSL D HDR
.Q
D ^%ZISC Q
HDR I $E(IOST,1,2)="C-" W !,"PRESS RETURN TO CONTINUE OR '^' TO EXIT " R X:DTIME S END='$T!(X="^") Q:END ;
HDR1 W @IOF
HDR2 S TOP="NON FORMULARY REQUEST FOR "_$P(^DPT($P(^APSQNF(DA,0),U,3),0),U)
S LENG=$L(TOP)
S PAGE=PAGE+1 W ?(IOM-LENG/2),TOP,?(IOM-12),"PAGE: ",$J(PAGE,3)
Q
;
RX ;EP COMES FROM PSODRG TO CHECK IF NON FORMULARY REQUEST FOR NF DRUG
;PSODFN IS PATIENT,PSODRUG("IEN") IS DRUG
;ROUTINES PSODRG PSORXI MODIFIED
D RX^APSQCK1 ;CONTINUE IN APSQCK1
Q
RXSET ;EP SET THE REFERENCE RX FIELD
;CALLED FROM PSON52 AND PSOR52
;WITH NFRXIEN DEFINED AS PSRX IEN
D RXSET^APSQCK1
Q
RXSETK ;EP KILL PRESCRIPTION REFERENCE IF RX DELETED
;VARIABLE NFRXIEN PASSED FROM DA IN PSORXDL
;S KILL=$O(^APSQNF(XREF,NFRXIEN,""))
D RXSETK^APSQCK1 ;CONTINUE IN APSQCK1
Q
;
POST D POST^APSQCK2 Q
Q
APSQCK ;IHS/ASDS/ENM/POC - CALLS TO NON FORMULARY REQUEST [ 11/20/2001 2:36 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3,4**;FEB 20, 2001
+2 ;PROGRAM FOR ALL CALLS TO NON FORMULARY REQUEST [ 01/24/2001 1:02 PM ]
+3 ;CALLS FROM PSORXDL PSON52 PSORN52 ROUTINES
+4 ;A XREF LOOKUP TO KEEP PROVIDER FROM GIVING SAME DRUG TO SAME PERSON ON SAME DAY OR HAVE A RECORD OPEN FOR PATIENT AND A SAME DRUG
+5 ;D EN^XBVK("APSQC")
+6 QUIT
CK ;EP
+1 ;CONTINUE IN APSQCK
DO CK^APSQCK1
+2 QUIT
LOOK ;EP LOOK UP AN ENTRY AND DO SOMETHING
+1 ;S LOOK TO PRINT TO PRINT OR XMB TO SEND MESSAGE
+2 ;CONTINUED IN APSQCK1
DO LOOK^APSQCK1
+3 QUIT
+4 ;
APROV ;EP ENTRY POINT TO APPROVE NON FORMULARY REQUEST
+1 WRITE @IOF
+2 WRITE !!!
+3 IF '+($GET(^VA(200,DUZ,"PS")))
WRITE !,"YOU DON'T HAVE AUTHORIZATION TO WRITE MED ORDERS SO-BYE"
GOTO EXIT
+4 WRITE "ENTER YOUR ELECTRONIC SIGNATURE TO APPROVE A NON FORMULARY REQUESTS"
+5 DO SIG^XUSESIG
+6 IF X1=""
WRITE @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!"
GOTO EXIT
APROVA ;MOVE THIS BACK ON EXIT ACTION OF MENU
IF '$DATA(DUZSAVE)
SET DUZSAVE=DUZ
SET DUZ=0
+1 KILL FROM,HIT
+2 ;REQUESTING PROVIDER MUST BE FILLED IN AND APPROVING PROVIDER MUST BE NULL OR DUZ P/T MUST NOT HAVE SIGNATURE
+3 ;S FROM="",SCR="I $P(^(0),U,11)]"""",$S($P(^(1),U,2)="""":1,1:$P(^(1),U,2)=DUZSAVE)"
+4 SET FROM=""
SET SCR="I $P(^(0),U,11)]"""",$S($P(^(1),U,2)="""":1,1:$P(^(1),U,2)=DUZSAVE),$P(^(1),U,4)="""""
+5 DO LIST1
+6 ;I '$D(HIT) G EXIT
+7 IF $DATA(EXIT)
GOTO EXIT
IF '$DATA(HIT)
GOTO APROVA
FROMA WRITE @IOF
+1 KILL DIC,DR
+2 SET DA=HIT
SET DIC="^APSQNF("
SET DIQ(0)="C"
+3 DO EN^DIQ
+4 KILL DIR
+5 IF $PIECE(^APSQNF(HIT,1),U,2)]""
SET DEL=1
+6 SET DIR("A")="DO YOU WANT TO "_$SELECT($DATA(DEL):"DELETE",1:"APPLY")_" YOUR ELECTRONIC SIGNATURE TO NON FORMULARY REQUEST "_$PIECE(^APSQNF(HIT,0),U)
+7 SET DIR(0)="Y"
+8 DO ^DIR
KILL DR,DIC
+9 ;I Y'=1 G EXIT
+10 ;I Y'=1 G APROVA
+11 ;MEANS I CAME FROM RPROV AND GO BACK
IF (Y'=1)
IF ($DATA(RPROV))
KILL RPROV
QUIT
+12 IF Y'=1
GOTO APROVA
+13 IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
GOTO EXIT
+14 SET DIE="^APSQNF("
SET DA=HIT
+15 IF $DATA(DEL)
SET DR="5///@"
+16 IF '$TEST
SET DR="5///`"_$SELECT($DATA(DUZSAVE):DUZSAVE,1:DUZ)
+17 DO ^DIE
+18 IF '$DATA(Y)
WRITE !,"YOUR SIGNATURE HAS BEEN "_$SELECT($DATA(DEL):"DELETED",1:"APPLIED")
HANG 2
+19 ;PUT THESE LINES IN ***
+20 IF $GET(HIT)
IF '$DATA(DEL)
Begin DoDot:1
+21 ;REQUESTING PROVIDER
IF $PIECE(^APSQNF(HIT,0),U,11)
SET PERSON($PIECE(^(0),U,11))=""
+22 ;APPROVING PROVIDER
IF $PIECE(^APSQNF(HIT,1),U,2)
SET PERSON($PIECE(^(1),U,2))=""
+23 ;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
+24 DO BULL(HIT,"APSQ NF APPROVING BULLETIN",.PERSON)
+25 KILL DEL
+26 QUIT
End DoDot:1
+27 KILL HIT,DEL
+28 ;IF COME FROM RPROV WANT TO GO BACK
IF $DATA(RPROV)
KILL RPROV
QUIT
+29 GOTO APROVA
+30 ;D EXIT
+31 QUIT
PHAR ;EP ENTRY POINT TO EDIT NON FORMULARY REQUEST BY A PHARMACIST
+1 WRITE @IOF
+2 WRITE !!!
+3 IF '$DATA(^XUSEC("PSORPH",DUZ))
WRITE !,"YOU MUST HAVE THE 'PSORPH' KEY TO CONTINUE-BYE"
GOTO EXIT
+4 WRITE "ENTER YOUR ELECTRONIC SIGNATURE TO EDIT NON FORMULARY REQUESTS"
+5 DO SIG^XUSESIG
+6 IF X1=""
WRITE @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!"
GOTO EXIT
PHARA IF '$DATA(DUZSAVE)
SET DUZSAVE=DUZ
SET DUZ=0
+1 ;
+2 ;LIST NON FORMULARY REQUEST BY RPH
+3 KILL FROM
+4 ;SCREEN IS MUST HAVE REQUESTING AND APPROVING PROVIDER,RPH MUST BE NULL OR DUZ, P/T MUST NOT HAVE SIGNED
+5 SET FROM=""
SET SCR="I $P(^(0),U,11)]"""",$P(^(1),U,2)]"""",$S($P(^(1),U,4)="""":1,1:$P(^(1),U,4)=DUZSAVE),$P(^(1),U,6)="""""
+6 DO LIST1
DO EDIT1
+7 ;**** GOTO
IF $GET(Y)'="^"
GOTO PHARA
+8 ;F D LIST1,EDIT1 Q:$D(DTOUT)
+9 QUIT
PTPROV ;EP ENTRY POINT TO ADD/EDIT NON FORMULARY REQUEST
+1 WRITE @IOF
+2 WRITE !!!
+3 IF '$DATA(^XUSEC("PSORPH",DUZ))
WRITE !,"YOU MUST HAVE THE 'PSORPH' KEY TO CONTINUE-BYE"
GOTO EXIT
+4 WRITE "ENTER YOUR ELECTRONIC SIGNATURE TO ADD/EDIT NON FORMULARY REQUESTS"
+5 DO SIG^XUSESIG
+6 IF X1=""
WRITE @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!"
GOTO EXIT
PTPROVA IF '$DATA(DUZSAVE)
SET DUZSAVE=DUZ
SET DUZ=0
+1 ;
+2 ;LIST NON FORMULARY REQUEST BY REQ PROVIDER WITH APP PROVIDER=""
+3 KILL FROM
+4 SET FROM=""
+5 ;RREQUESTING PROVIDER, APPROVING PROVIDER, RPH MUST NOT BE NULL AND PT REVIEWER MUST BE NULL OR DUZ
+6 SET SCR="I $P(^(0),U,11)]"""",$P(^(1),U,2)]"""",$P(^(1),U,4)]"""",$S($P(^(1),U,6)="""":1,1:$P(^(1),U,6)=DUZSAVE)"
+7 DO LIST1
DO EDIT2
+8 IF $GET(Y)'="^"
GOTO PTPROVA
+9 QUIT
RPROV ;EP ENTRY POINT TO ADD/EDIT NON FORMULARY REQUEST
+1 ;THIS ENTRY POINT HAS THE REAL DUZ ONLY
+2 WRITE @IOF
+3 WRITE !!!
+4 IF '+($GET(^VA(200,DUZ,"PS")))
WRITE !,"YOU DON'T HAVE AUTHORIZATION TO WRITE MED ORDERS SO-BYE"
GOTO EXIT
+5 WRITE "ENTER YOUR ELECTRONIC SIGNATURE TO ADD/EDIT NON FORMULARY REQUESTS"
+6 DO SIG^XUSESIG
+7 IF X1=""
WRITE @IOF,!!,*7,*7,"SORRY THAT ELECTRONIC SIG NOT CORRECT!!"
GOTO EXIT
+8 ;
RPROVA ;LIST NON FORMULARY REQUEST BY REQ PROVIDER WITH APP PROVIDER=""
+1 KILL FROM
+2 ;REQUESTING PROVIDER MUST BE DUZ AND APPROVING PROVIDER MUST BE NULL
+3 ;S FROM="",SCR="I $P(^(0),U,11)=DUZ,$P(^(1),U,2)="""""
+4 SET FROM=""
SET SCR="I $P(^(0),U,11)=DUZ,$P(^(1),U,2)="""",$$PASS^APSQCK($P(^(0),U,11))"
+5 ;S FROM="",SCR="I 1"
+6 ;D LIST1,EDIT
+7 DO LIST1
+8 IF $DATA(EXIT)
GOTO EXIT
+9 DO EDIT
+10 IF $DATA(EXIT)
GOTO EXIT
+11 ;I $D(^XUSEC("APSQ NF APPROVING PROVIDER",DUZ)) D I %=1 S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE S RPROV=1 D APROVA
+12 ;.W !,"WOULD YOU LIKE TO APPROVE THE NON FORMULARY REQUEST ALSO SINCE YOU HAVE THE KEY"
+13 ;.S %=1 D YN^DICN
+14 ;G:$D(EXIT) EXIT
+15 ;I $G(Y)'="^" G RPROVA
+16 GOTO RPROVA
+17 QUIT
LIST1 KILL OUT,DISP
+1 DO LIST^DIC(9009035.1,"",".01;1;2;3","B",3,.FROM,"","DT","X SCR","","OUT","ERR")
+2 WRITE @IOF,!
+3 SET NUM=+OUT("DILIST",0)
SET MORE=$PIECE(OUT("DILIST",0),U,3)
+4 SET CNT=0
+5 SET SEQ=""
FOR
SET SEQ=$ORDER(OUT("DILIST",1,SEQ),-1)
IF SEQ=""
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 SET IEN=OUT("DILIST",2,SEQ)
+8 SET DISP(CNT,"IEN")=IEN
+9 SET DISP(CNT)="#"_CNT_":"
+10 SET I=""
FOR
SET I=$ORDER(OUT("DILIST","ID",SEQ,I))
IF I=""
QUIT
Begin DoDot:2
+11 SET DISP(CNT)=DISP(CNT)_" "_OUT("DILIST","ID",SEQ,I)
End DoDot:2
End DoDot:1
+12 FOR I=1:1
IF '$DATA(DISP(I))
QUIT
SET DISP(I)=$EXTRACT(DISP(I),1,75)
WRITE !,DISP(I)
+13 ;K DISP,OUT
DIR ;
+1 SET DIR(0)="NO^1:"_NUM
+2 SET DIR("A")="ENTER A NUMBER TO EDIT OR '^' TO EDIT NONE"
+3 DO ^DIR
KILL DIR
+4 ;I $D(DTOUT)!(Y="^") S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE G EXIT ;*****
+5 ;*****
IF $DATA(DTOUT)!(Y="^")
IF $DATA(DUZSAVE)
SET DUZ=DUZSAVE
KILL DUZSAVE
SET EXIT=1
QUIT
+6 ;G:$D(DTOUT)!(Y<1) EXIT ;****GOTO
+7 ;I ($D(DTOUT))!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) G EXIT
+8 ;888888
IF Y=""
IF MORE
KILL I,J,IEN,DISP
GOTO LIST1
+9 ;I Y="" K I,J,IEN,DISP G LIST1
+10 IF +Y
SET HIT=DISP(+Y,"IEN")
+11 KILL Y,DIR
+12 QUIT
EDIT2 ;EDIT A SCREEN FORM USING IEN FOR DA
+1 IF $DATA(DUZSAVE)
SET DUZ=DUZSAVE
KILL DUZSAVE
+2 ;K HIT
IF $DATA(HIT)
SET DA=HIT
SET ADD=0
+3 ;E D ADD S ADD=1
+4 IF $DATA(EXIT)
GOTO EXIT
+5 SET DDSFILE=9009035.1
+6 SET DR="[APSQ NF PT]"
+7 SET DDSPARM="CES"
+8 DO ^DDS
+9 ;WANT TO DELETE IF ADDED BUT NOT SAVED
+10 ;IF $D(DDSAVE) THEN FORM WAS SAVED
+11 ;I '$D(DDSAVE),ADD S DA=HIT,DIK="^APSQNF(" D ^DIK K HIT,DA,DIK
+12 ;D ^ZTER
+13 IF $GET(HIT)
IF $DATA(DDSSAVE)
IF $DATA(DDSCHANG)
Begin DoDot:1
+14 ;REQUESTING PROVIDER
IF $PIECE(^APSQNF(HIT,0),U,11)
SET PERSON($PIECE(^(0),U,11))=""
+15 ;PHARMACIST
IF $PIECE(^APSQNF(HIT,1),U,6)
SET PERSON($PIECE(^(1),U,6))=""
+16 ;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
+17 DO BULL(HIT,"APSQ NF REQUESTING BULLETIN",.PERSON)
+18 QUIT
End DoDot:1
+19 ;D ^ZTER
+20 KILL HIT
+21 DO EXIT
+22 QUIT
EDIT1 ;EDIT A SCREEN FORM USING IEN FOR DA
+1 IF $DATA(DUZSAVE)
SET DUZ=DUZSAVE
KILL DUZSAVE
+2 ;K HIT
IF $DATA(HIT)
SET DA=HIT
SET ADD=0
+3 ;E D ADD S ADD=1
+4 IF $DATA(EXIT)
GOTO EXIT
+5 SET DDSFILE=9009035.1
+6 SET DR="[APSQ NF PHARMACIST]"
+7 SET DDSPARM="CES"
+8 DO ^DDS
+9 ;WANT TO DELETE IF ADDED BUT NOT SAVED
+10 ;IF $D(DDSSAVE) THEN FORM WAS SAVED
+11 ;I '$D(DDSSAVE),ADD S DA=HIT,DIK="^APSQNF(" D ^DIK K HIT,DA,DIK
+12 ;D ^ZTER
+13 IF $GET(HIT)
IF $DATA(DDSSAVE)
IF $DATA(DDSCHANG)
Begin DoDot:1
+14 ;REQUESTING PROVIDER
IF $PIECE(^APSQNF(HIT,0),U,11)
SET PERSON($PIECE(^(0),U,11))=""
+15 ;PHARMACIST
IF $PIECE(^APSQNF(HIT,1),U,4)
SET PERSON($PIECE(^(1),U,4))=""
+16 ;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
+17 DO BULL(HIT,"APSQ NF REQUESTING BULLETIN",.PERSON)
+18 QUIT
End DoDot:1
+19 ;D ^ZTER
+20 KILL HIT
+21 DO EXIT
+22 QUIT
EDIT ;EDIT A SCREEN FORM USING IEN FOR DA
+1 ;K HIT
IF $DATA(HIT)
SET DA=HIT
SET ADD=0
+2 IF '$TEST
DO ADD
SET ADD=1
+3 ;G:$D(EXIT) EXIT
+4 ;Q:$D(EXIT1) ;NOTE THIS IS EXIT1
+5 ;IHS/OKCAO/POC 6/5/2001
IF $DATA(EXIT1)
KILL EXIT1
QUIT
+6 SET DDSFILE=9009035.1
+7 SET DR="[APSQ NF REQUEST]"
+8 SET DDSPARM="CES"
+9 DO ^DDS
+10 ;I $D(DDSCHANG) W "IT WAS CHANGED" S ^PAT("CHANGED")=1 ;***
+11 ;IF $D(KILL) I DELETED FORM ENTRY THRU VALIDATION OF FORM
+12 ;I KILL K KILL G EXIT
+13 ;IHS/ITSC/ENM 11/20/2001
IF $DATA(KILL)
KILL KILL
GOTO EXIT
+14 ;WANT TO DELETE IF ADDED BUT NOT SAVED
+15 ;IF $D(DDSSAVE) THEN FORM WAS SAVED
+16 IF '$DATA(DDSSAVE)
IF ADD
SET DA=HIT
SET DIK="^APSQNF("
DO ^DIK
KILL HIT,DA,DIK
+17 ;REQUESTING PROVIDER
IF $GET(HIT)
IF $PIECE(^APSQNF(HIT,0),U,11)
SET PERSON($PIECE(^(0),U,11))=""
+18 ;UNCOMMENT THIS NEXT LINE IF WANT BULLETIN FIRED
+19 IF $DATA(DDSSAVE)
IF $DATA(DDSCHANG)
DO BULL(HIT,"APSQ NF REQUESTING BULLETIN",.PERSON)
+20 ;I $D(^XUSEC("APSQ NF APPROVING PROVIDER",DUZ)) D I %=1 S:$D(DUZSAVE) DUZ=DUZSAVE K DUZSAVE S RPROV=1 D FROMA
+21 ;IHS/OKCAO/POC 6/4/2001
IF ($DATA(^XUSEC("APSQ NF APPROVING PROVIDER",DUZ)))&($GET(HIT))
Begin DoDot:1
+22 WRITE !,"WOULD YOU LIKE TO APPROVE THE NON FORMULARY REQUEST ALSO SINCE YOU HAVE THE KEY"
+23 SET %=1
DO YN^DICN
End DoDot:1
IF %=1
IF $DATA(DUZSAVE)
SET DUZ=DUZSAVE
KILL DUZSAVE
SET RPROV=1
IF $GET(HIT)
DO FROMA
+24 KILL HIT
+25 DO EXIT
+26 QUIT
ADD ;CALL DIC TO ADD AND THEN DDS TO EDIT
+1 SET DIR(0)="Y"
SET DIR("A")="DO YOU WANT TO ENTER A NEW NON FORMULARY REQUEST"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+2 ;NOTE IT'S EXIT1
IF Y'=1
SET EXIT1=1
+3 ;Q:$D(EXIT1)
+4 ;IHS/OKCAO/POC 6/5/2001
IF $DATA(EXIT1)
KILL EXIT1
QUIT
+5 SET DIC="^APSQNF("
SET DIC(0)="LMNO"
+6 SET X=$ORDER(^APSQNF("9999999999"),-1)+1
SET X=""""_X_""""
+7 DO ^DIC
+8 ;G EXIT
IF Y<1
WRITE !,"SOMETHING WRONG DID NOT ADD ENTRY"
SET EXIT=1
QUIT
+9 SET (HIT,DA)=+Y
+10 QUIT
+11 ;
EXIT ;CLEAN UP TIME
+1 IF $DATA(DUZSAVE)
SET DUZ=DUZSAVE
KILL DUZSAVE
+2 KILL EXIT
+3 ;IHS/OKCAO/POC 6/5/2001
KILL EXIT1
+4 KILL OUT,DISP
+5 KILL DDSPARM,DDSFILE,DR,DA,DDSSAVE,DDSCHANG
+6 KILL ADD,CNT,PERSON,NUM,MORE,SCR,SEQ,IEN,I,FROM,GET,DEL,HIT
+7 ;K ADD,CNT,PERSON,NUM,MORE,SCR,SEQ,IEN,I,GET,DEL,HIT
+8 KILL XMB,XMDUZ
+9 QUIT
VAL1 ;EP CALLED FROM SCREENMAN UPON VALIDATING THE FORM APSQ NF PHARMACIST
+1 ;I MIGHT NOT USE THIS
+2 ;CONTINUED IN APSQCK1
DO VAL1^APSQCK1
+3 QUIT
VAL2 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE FORM
+1 ;CONTINUED IN APSQCK1
DO VAL2^APSQCK1
+2 QUIT
VAL3 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
+1 ;CONTINUE IN APSQCK1
DO VAL3^APSQCK1
+2 QUIT
VAL33 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
+1 ;CONTINUE IN APSQCK1
DO VAL33^APSQCK1
+2 QUIT
VAL4 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
+1 ;CONTINUE IN APSQCK1
DO VAL4^APSQCK1
+2 QUIT
VAL44 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
+1 ;CONTINUE IN APSQCK1
DO VAL44^APSQCK1
+2 QUIT
BULL(GOTIT,BULLETIN,XMY) ;SEND A BULLETIN GOTIT IS THE IEN OF APSQNF( AND BULLETIN IS NAME OF BULLETIN
+1 ;GOTIT IS THE IEN OF NONFORMULARY REQUEST
+2 ;BULLETIN IS NAME OF BULLETIN TO USE
+3 ;WHO IS ADDITIONAL PERSON TO SEND BULLETIN TO
+4 WRITE !!,"BULLETIN BEING SENT",!!
+5 ;S GOTIT="SOMETHING"
+6 ;WANT IEN I THINK
SET GOTIT="`"_GOTIT
+7 DO FIND^DIC(9009035.1,,".01;2;3;4;4.1;5;5.1;6;6.1;7;7.1;7.5",,GOTIT,,,,,"GET","OUCH")
+8 ;MAKE IT EASIER TO WORK WITH
MERGE XMB=GET("DILIST","ID",1)
+9 DO BULL2
+10 DO BULL1
+11 QUIT
BULL1 SET XMDUZ=.5
+1 SET XMB=BULLETIN
+2 DO ^XMB
+3 KILL XMY
+4 QUIT
+5 ;
BULL2 ;ADD ANY EXTRA PEOPLE TO BULLETIN
+1 WRITE !,"ADDITIONAL ENTRIES MAY BE ADDED TO THE BULLETIN"
+2 WRITE !,"REMEMBER ENTRIES HAVE BEEN ADDED FOR YOURSELF AND THE BULLETIN MAILGROUPS"
DIC SET DIC(0)="AEMQ"
+1 SET DIC="^VA(200,"
+2 SET DIC("S")="I ($P(^(0),U,3)'="""")&($S($P(^(0),U,11)]"""":$P(^(0),U,11),1:9999999)>DT)"
+3 SET DIC("A")="ADDITIONAL 'LOCAL USER' TO THE BULLETIN //"
+4 DO ^DIC
+5 IF Y>0
SET XMY(+Y)=""
GOTO DIC
+6 KILL DIC
+7 QUIT
+8 SET XMZ=$$FIND1^DIC(3.6,"","MX",BULLETIN)
+9 SET XMDUZ=.5
+10 SET XMDUN=""
+11 DO DEST^XMA21
+12 ;GETS XMY ARRAY
+13 ;W !,"SOME STUFF HERE"
+14 QUIT
PASS(PROV) ;EP CHECK IF THIS IS A VALID NEW PERSON TO LOOK AT THIS ENTRY
+1 IF '$GET(PROV)
QUIT 1
+2 ;PROV WOULD BE THE REQUESTING PROVIDER. WOULD TAKE THIS PROV
+3 ;AND LOOK IN A NEW FILE WITH WHO CAN SIGN OFF AT VARIOUS STAGES
+4 ;CHECK WHO CAN SIGN OFF AGAINST DUZ
+5 ;AND RETURN THE QUIT VALUE AS 1 OR 0
+6 QUIT 1
+7 ;
PRINT ;PRINT OR BROWSE A NON FORMULARY REQUEST
+1 KILL DIR
+2 SET DIR(0)="SO^P:PRINT NON FORMULARY REQUEST;B:BROWSE NON FORMULARY REQUST"
+3 SET DIR("A")="DO YOU WANT TO "
+4 SET DIR("B")="PRINT"
+5 WRITE !
+6 DO ^DIR
+7 KILL DIR
+8 ;CHECK THIS ***
IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+9 IF $EXTRACT($GET(X))="P"
DO PRT
QUIT
+10 IF $EXTRACT($GET(X))="B"
DO BROWSE
QUIT
+11 QUIT
BROWSE ; BROWSE IT
+1 ;NEED ENTRY XB... IN LIST TEMPLATE FILE
+2 SET TOP="NON FORMULARY REQUEST FOR "_$PIECE(^DPT($PIECE(^APSQNF(DA,0),U,3),0),U)
+3 ;D VIEWR^XBLM("EN^DIQ","NON FORMULARY REQUEST FOR "_TOP)
+4 DO VIEWR^XBLM("PRT1^APSQCK","NON FORMULARY REQUEST FOR "_TOP)
+5 QUIT
+6 ;
PRT ;PRINT IT
+1 SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO EXIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="PRT1^APSQCK"
SET ZTDESC="PRINT OF ONE NON FORMULARY REQUEST"
End DoDot:1
DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
QUIT
PRT1 ;EP
+1 SET (END,NUMPT,PAGE)=0
+2 USE IO
+3 DO @("HDR"_(2-($EXTRACT(IOST,1,2)="C-")))
+4 SET ARRAY=0
FOR
SET ARRAY=$ORDER(ARRAY(ARRAY))
IF ARRAY=""!END
QUIT
Begin DoDot:1
+5 WRITE !,ARRAY(ARRAY)
+6 IF ($Y+5)>IOSL
DO HDR
+7 QUIT
End DoDot:1
+8 DO ^%ZISC
QUIT
HDR ;
IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"PRESS RETURN TO CONTINUE OR '^' TO EXIT "
READ X:DTIME
SET END='$TEST!(X="^")
IF END
QUIT
HDR1 WRITE @IOF
HDR2 SET TOP="NON FORMULARY REQUEST FOR "_$PIECE(^DPT($PIECE(^APSQNF(DA,0),U,3),0),U)
+1 SET LENG=$LENGTH(TOP)
+2 SET PAGE=PAGE+1
WRITE ?(IOM-LENG/2),TOP,?(IOM-12),"PAGE: ",$JUSTIFY(PAGE,3)
+3 QUIT
+4 ;
RX ;EP COMES FROM PSODRG TO CHECK IF NON FORMULARY REQUEST FOR NF DRUG
+1 ;PSODFN IS PATIENT,PSODRUG("IEN") IS DRUG
+2 ;ROUTINES PSODRG PSORXI MODIFIED
+3 ;CONTINUE IN APSQCK1
DO RX^APSQCK1
+4 QUIT
RXSET ;EP SET THE REFERENCE RX FIELD
+1 ;CALLED FROM PSON52 AND PSOR52
+2 ;WITH NFRXIEN DEFINED AS PSRX IEN
+3 DO RXSET^APSQCK1
+4 QUIT
RXSETK ;EP KILL PRESCRIPTION REFERENCE IF RX DELETED
+1 ;VARIABLE NFRXIEN PASSED FROM DA IN PSORXDL
+2 ;S KILL=$O(^APSQNF(XREF,NFRXIEN,""))
+3 ;CONTINUE IN APSQCK1
DO RXSETK^APSQCK1
+4 QUIT
+5 ;
POST DO POST^APSQCK2
QUIT
+1 QUIT
