Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSQCK

APSQCK.m

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