APSQCK1 ;IHS/ASDS/ENM/POC - CONT OF APSQCK NON FORMULARY CALL [ 06/07/2001 10:56 AM ]
;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
;PROGRAM FOR ALL CALLS TO NON FORMULARY REQUEST [ 01/22/01 10:42 PM ]
;CONTINUATION FROM APSQCK
;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
K APSQ("PAT"),APSQ("DRUG"),APSQ("DT")
S JOB=$J
;M APSQC=^TMP("DDS",JOB,+DDS,"F"_DDSFILE,"11,") ;)_")") ;,"11,"_")"))
M APSQC=^TMP("DDS",JOB,+DDS,"F"_DDSFILE,DDSDA) ;)_")") ;,"11,"_")"))
;W ABC
S APSQ("PAT")=$G(APSQC(2,"D"))
Q:APSQ("PAT")']""
;S APSQ("DRUG")=$G(APSQC(3,"D"))
S APSQ("DRUG")=$G(DDSY)
Q:APSQ("DRUG")']""
S APSQ("DT")=$G(APSQC(1,"D"))
Q:APSQ("DT")']""
I $D(^APSQNF("M",APSQ("PAT"),APSQ("DRUG"),APSQ("DT"))) S DDSERROR=1 D
.S MSG("DIHELP",1)="THIS PATIENT ALREADY HAS A NON FORMULARY REQUEST FOR THIS DRUG TODAY" D MSG^DIALOG("WH","",60,"","MSG")
.Q
I $D(DDSERROR) D EN^XBVK("APSQ") Q
;
;CANT HAVE ANY RECORD FOR THIS PATIENT AND THIS DRUG "OPEN"
S APSQ("QUIT")=0
S APSQ("DT")=0 F S APSQ("DT")=$O(^APSQNF("M",APSQ("PAT"),APSQ("DRUG"),APSQ("DT"))) Q:(APSQ("DT")="")!APSQ("QUIT") S APSQ("RECIEN")=^(APSQ("DT")) D
.Q:APSQ("RECIEN")=""
.S APSQ("CLOSED")=$P($G(^APSQNF(APSQ("RECIEN")),1),U,8)
.Q:APSQ("CLOSED")]"" ;RECORD CLOSED
.S DDSERROR=1,APSQ("QUIT")=1
.Q
D EN^XBVK("APSQ")
Q
LOOK ;EP LOOK UP AN ENTRY AND DO SOMETHING
;S LOOK TO PRINT TO PRINT OR XMB TO SEND MESSAGE
W !,"YOU MAY LOOK UP ENTRIES BY CONTROL #, PATIENT, DRUG, OR DATE"
K DIC
S DIC="^APSQNF(",DIC(0)="AEMO"
S DIC("A")="WHAT NON FORMULARY REQUEST DO YOU WANT TO SELECT? "
D ^DIC
;S DUZ=DUZSAVE K DUZSAVE
;G:Y<1 EXIT
;I (Y<1)!($D(DTOUT))!($D(DUOUT)) G EXIT
I (Y<1)!($D(DTOUT))!($D(DUOUT))!(+Y=0) G EXIT ;IHS/OKCAO/POC 3/12/2001
E S DA=+Y D WRITE,@LOOK
G EXIT
Q
;
;BELOW CAN SEND A MESSAGE TO WHOEVER FOR THE NON FORMULARY REQUEST
WRITE ;
K ^UTILITY("DIQ1",$J)
S DR=".01:999",DIQ(0)="E"
D EN^XBNEW("EN^DIQ1","DIC;DR;DA;DIQ*") ;HAVE WE SOME CONFLICT HERE 1/21/2001
;D EN^DIQ1 ;TO GET WRITTEN TO ^UTILITY("DIQ1",$J,ETC
M DD=^UTILITY("DIQ1",$J)
S FILE=$O(DD(""))
S DA=$O(DD(FILE,""))
S FIELD=0 F I=1:1 S FIELD=$O(DD(FILE,DA,FIELD)) Q:FIELD="" D
.S NAME=$P(@("^DD("_FILE_","_FIELD_",0)"),"^",1)
.I $D(DD(FILE,DA,FIELD,"E")) S NAME=NAME_":"_DD(FILE,DA,FIELD,"E")
.S ARRAY(FIELD)=NAME
.S ARRAY(FIELD-.00001)=""
.S LAST=0,J=FIELD F J=J+.00001:.00001 S LAST=$O(DD(FILE,DA,FIELD,LAST)) Q:LAST'=+LAST D
..S ARRAY(J)=DD(FILE,DA,FIELD,LAST)
Q
XMB ;SEND TO WHO EVER
S XMTEXT="ARRAY(" ;THE ABOVE JUST MADE ABOVE BY WRITE
S XMSUB="NON FORMULARY REQUEST FROM "_$P(^DIC(4,DUZ(2),0),U,1)
S XMDUZ=$S($D(DUZSAVE):DUZSAVE,1:DUZ)
D ^XMD
Q
EXIT ;CLEAN UP TIME
I $D(DUZSAVE) S DUZ=DUZSAVE K DUZSAVE
K EXIT
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
S CHECK=$$GET^DDSVALF(8,2,1,"I") ;CHECK IF RPH WANTS TO SAVE FORM
I CHECK D
.S HELP(1)="SAVE AND EXIT THE FORM IF YOU WANT TO SAVE YOUR DATA"
.D HLP^DDSUTL(.HELP)
.K DDSERROR
.;S DDSBR="COM"
.Q
I 'CHECK D
.S HELP(1)="*************"
.S HELP(2)="IF YOU WANT TO SAVE THE FORM"
.S HELP(3)="CHANGE THE SAVE THE FORM FIELD TO 'YES'"
.D HLP^DDSUTL(.HELP)
.K HELP
.S DDSBR="8"
.S DDSERROR=1
.Q
K CHECK,HELP
Q
VAL2 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE FORM
S KILL=$$GET^DDSVALF(20,1,1,"I")
I KILL S DIK="^APSQNF(" D ^DIK
;K KILL,DIK,DA
K DIK,DA
Q
VAL3 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
S KILL=$$GET^DDSVALF(8,3,1,"I")
I KILL D ;
.S DIE="^APSQNF(",DR="6///@;10///@;11///@;12///@;13///@;14///@;70///@" D ^DIE
.K DIE,DA
.Q
K KILL
Q
VAL33 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
S KILL=$$GET^DDSVALF(8,3,1,"I")
I KILL D ;
.S HELP(1)="IF YOU WANT TO SAVE THE PHARMACIST INFORMATION"
.S HELP(2)="CHANGE 'DELETE THE PHARMACY INFO AND YOUR SIGNATURE' TO 'NO'"
.S HELP(3)="IF YOU WANT TO DELETE THE PHARMACIST INFO-EXIT THE FORM W/O SAVING"
.D HLP^DDSUTL(.HELP)
.K HELP
.S DDSBR="8"
.S DDSERROR=1
.Q
K KILL
Q
VAL4 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
S KILL=$$GET^DDSVALF(7,2,1,"I")
I KILL D
.S DIE="^APSQNF(",DR="7///@;7.5///@;80///@" D ^DIE
.K DIE,DA
.Q
K KILL
Q
VAL44 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
S KILL=$$GET^DDSVALF(7,2,1,"I")
I KILL D
.S HELP(1)="IF YOU WANT TO SAVE THE P/T INFORMATION"
.S HELP(2)="CHANGE 'DELETE THE P/T INFO AND YOUR SIGNATURE' TO 'NO'"
.S HELP(3)="IF YOU WANT TO DELETE THE P/T INFO-EXIT THE FORM W/O SAVING"
.D HLP^DDSUTL(.HELP)
.K HELP
.S DDSBR="7"
.S DDSERROR=1
.Q
K KILL
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
W !,"CHECKING NON FORMULARY INFORMATION...",!
Q:('$D(PSODRUG("IEN"))!('$D(PSODFN))) ;I HAVEN'T A CLUE
Q:'$P(^PSDRUG(PSODRUG("IEN"),0),U,9) ;NOT A NF DRUG
S NFRXDRUG=PSODRUG("IEN")_";PSDRUG(" ;REMEMBER THIS FIELD IS VARIABLE
S NFRXPT=PSODFN
S NFRXDATE=$O(^APSQNF("M",NFRXPT,NFRXDRUG,""),-1)
I 'NFRXDATE W !,"NO NON FORMULARY REQUESTS EXISTS FOR THIS DRUG" G NFRXEND
S NFRXIEN=^APSQNF("M",NFRXPT,NFRXDRUG,NFRXDATE)
G:'NFRXIEN NFRXEND W !,"NON FORMULARY REQUEST "_$P(^APSQNF(NFRXIEN,0),U)_" EXISTS"
S NFRXSEC=$G(^APSQNF(NFRXIEN,1)) ;SECOND NODE
S NFRXREF=$P(NFRXSEC,U,15),NFRXAPP=$P(NFRXSEC,U,8)
I NFRXREF W !,"RX# "_+$G(^PSRX(NFRXREF,0))_" HAS BEEN FILLED PREVIOUSLY USING THIS NON FORMULARY REQUEST"
W !,"THIS NON FORMULARY REQUEST STATUS IS "_$S(NFRXAPP=1:"APPROVED",NFRXAPP=0:"NOT APPROVED",1:"NOT ACTED UPON YET")
NFRXEND ;FINISH
W !
D ASK
;S:('NFRXREF)&(NFRXAPP) NFRXAOK=1
D EN^XBVK("NFRX")
Q
ASK ;ASK WHAT IS TO BE DONE
;LETS DO REVERSE VIDEO
S X="IORVON;IORVOFF" D ENDR^%ZISS
;FIRST WRITE MESSAGES
S I="" F S I=$O(AZO(I)) Q:I="" W:I="MESS" IORVON W !,*7,AZO(I) W:I="MESS" IORVOFF
;S DIR("A")="WHAT IS YOUR POISON? "
S DIR("A")="WHAT IS YOUR CHOICE? "
S DIR("A",1)="1 DO YOU WANT TO DELETE THIS DRUG?"
S DIR("A",2)="2 DO AN INTERVENTION?"
S DIR("A",3)="3 DO BOTH 1 AND 2?"
S DIR("A",4)="4 JUST CONTINUE?"
S DIR("B")=1
S DIR(0)="N^1:4:0"
D ^DIR
;IF (Y="")!(Y["^") S Y=1
IF $D(DIRUT)!($D(DIROUT)) S Y=1
K DIR,DTOUT,DIRUT,DUOUT,DIROUT
D @Y
QUIT
;
1 ;DELETE THE DRUG
S PSORX("DFLG")=1,DGI=""
QUIT
2 ;DO AN INTERVENTION
S PSORX("INTERVENE")=4,DGI=""
;PSORXI WAS MODIFIED
;LOOK AT THIS 4/13/98 IHS/OKCAO/POC
QUIT
3 ;DO BOTH 1 AND 2
D 2,1
QUIT
4 ;DO NOTHING
QUIT
RXSET ;EP SET THE REFERENCE RX FIELD
;CALLED FROM PSON52 AND PSOR52
;WITH NFRXIEN DEFINED AS PSRX IEN
;QUIT
D RXSET1,STOP
Q
RXSET1 S NFRXDRUG=$P(^PSRX(NFRXIEN,0),U,6) ;DRUG IEN
Q:'$P(^PSDRUG(NFRXDRUG,0),U,9) ;NOT NON FORMULARY
S NFRXDRUG=NFRXDRUG_";PSDRUG(" ;REMEMBER THIS FIELD IS VARIABLE
S NFRXPT=PSODFN
S NFRXDATE=$O(^APSQNF("M",NFRXPT,NFRXDRUG,""),-1) I NFRXDATE S NFRXNON=^(NFRXDATE)
Q:'NFRXDATE ;NO NON FORMULARY REQUEST
Q:'NFRXNON ;I HAVEN'T A CLUE
I '$P($G(^APSQNF(NFRXNON,1)),U,15) S DIE="^APSQNF(",DA=NFRXNON,DR="14///"_"`"_NFRXIEN D ^DIE K DIE ;ONLY SET IF FIELD NOT NULL
Q
RXSETK ;EP KILL PRESCRIPTION REFERENCE IF RX DELETED
;VARIABLE NFRXIEN PASSED FROM DA IN PSORXDL
;S KILL=$O(^APSQNF(XREF,NFRXIEN,""))
S KILL=$O(^APSQNF("RX",NFRXIEN,""))
I KILL S DIE="^APSQNF(",DA=KILL,DR="14///@" D ^DIE K DIE
D STOP
Q
STOP D EN^XBVK("NFRX")
Q
APSQCK1 ;IHS/ASDS/ENM/POC - CONT OF APSQCK NON FORMULARY CALL [ 06/07/2001 10:56 AM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
+2 ;PROGRAM FOR ALL CALLS TO NON FORMULARY REQUEST [ 01/22/01 10:42 PM ]
+3 ;CONTINUATION FROM APSQCK
+4 ;CALLS FROM PSORXDL PSON52 PSORN52 ROUTINES
+5 ;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
+6 ;D EN^XBVK("APSQC")
+7 QUIT
CK ;EP
+1 KILL APSQ("PAT"),APSQ("DRUG"),APSQ("DT")
+2 SET JOB=$JOB
+3 ;M APSQC=^TMP("DDS",JOB,+DDS,"F"_DDSFILE,"11,") ;)_")") ;,"11,"_")"))
+4 ;)_")") ;,"11,"_")"))
MERGE APSQC=^TMP("DDS",JOB,+DDS,"F"_DDSFILE,DDSDA)
+5 ;W ABC
+6 SET APSQ("PAT")=$GET(APSQC(2,"D"))
+7 IF APSQ("PAT")']""
QUIT
+8 ;S APSQ("DRUG")=$G(APSQC(3,"D"))
+9 SET APSQ("DRUG")=$GET(DDSY)
+10 IF APSQ("DRUG")']""
QUIT
+11 SET APSQ("DT")=$GET(APSQC(1,"D"))
+12 IF APSQ("DT")']""
QUIT
+13 IF $DATA(^APSQNF("M",APSQ("PAT"),APSQ("DRUG"),APSQ("DT")))
SET DDSERROR=1
Begin DoDot:1
+14 SET MSG("DIHELP",1)="THIS PATIENT ALREADY HAS A NON FORMULARY REQUEST FOR THIS DRUG TODAY"
DO MSG^DIALOG("WH","",60,"","MSG")
+15 QUIT
End DoDot:1
+16 IF $DATA(DDSERROR)
DO EN^XBVK("APSQ")
QUIT
+17 ;
+18 ;CANT HAVE ANY RECORD FOR THIS PATIENT AND THIS DRUG "OPEN"
+19 SET APSQ("QUIT")=0
+20 SET APSQ("DT")=0
FOR
SET APSQ("DT")=$ORDER(^APSQNF("M",APSQ("PAT"),APSQ("DRUG"),APSQ("DT")))
IF (APSQ("DT")="")!APSQ("QUIT")
QUIT
SET APSQ("RECIEN")=^(APSQ("DT"))
Begin DoDot:1
+21 IF APSQ("RECIEN")=""
QUIT
+22 SET APSQ("CLOSED")=$PIECE($GET(^APSQNF(APSQ("RECIEN")),1),U,8)
+23 ;RECORD CLOSED
IF APSQ("CLOSED")]""
QUIT
+24 SET DDSERROR=1
SET APSQ("QUIT")=1
+25 QUIT
End DoDot:1
+26 DO EN^XBVK("APSQ")
+27 QUIT
LOOK ;EP LOOK UP AN ENTRY AND DO SOMETHING
+1 ;S LOOK TO PRINT TO PRINT OR XMB TO SEND MESSAGE
+2 WRITE !,"YOU MAY LOOK UP ENTRIES BY CONTROL #, PATIENT, DRUG, OR DATE"
+3 KILL DIC
+4 SET DIC="^APSQNF("
SET DIC(0)="AEMO"
+5 SET DIC("A")="WHAT NON FORMULARY REQUEST DO YOU WANT TO SELECT? "
+6 DO ^DIC
+7 ;S DUZ=DUZSAVE K DUZSAVE
+8 ;G:Y<1 EXIT
+9 ;I (Y<1)!($D(DTOUT))!($D(DUOUT)) G EXIT
+10 ;IHS/OKCAO/POC 3/12/2001
IF (Y<1)!($DATA(DTOUT))!($DATA(DUOUT))!(+Y=0)
GOTO EXIT
+11 IF '$TEST
SET DA=+Y
DO WRITE
DO @LOOK
+12 GOTO EXIT
+13 QUIT
+14 ;
+15 ;BELOW CAN SEND A MESSAGE TO WHOEVER FOR THE NON FORMULARY REQUEST
WRITE ;
+1 KILL ^UTILITY("DIQ1",$JOB)
+2 SET DR=".01:999"
SET DIQ(0)="E"
+3 ;HAVE WE SOME CONFLICT HERE 1/21/2001
DO EN^XBNEW("EN^DIQ1","DIC;DR;DA;DIQ*")
+4 ;D EN^DIQ1 ;TO GET WRITTEN TO ^UTILITY("DIQ1",$J,ETC
+5 MERGE DD=^UTILITY("DIQ1",$JOB)
+6 SET FILE=$ORDER(DD(""))
+7 SET DA=$ORDER(DD(FILE,""))
+8 SET FIELD=0
FOR I=1:1
SET FIELD=$ORDER(DD(FILE,DA,FIELD))
IF FIELD=""
QUIT
Begin DoDot:1
+9 SET NAME=$PIECE(@("^DD("_FILE_","_FIELD_",0)"),"^",1)
+10 IF $DATA(DD(FILE,DA,FIELD,"E"))
SET NAME=NAME_":"_DD(FILE,DA,FIELD,"E")
+11 SET ARRAY(FIELD)=NAME
+12 SET ARRAY(FIELD-.00001)=""
+13 SET LAST=0
SET J=FIELD
FOR J=J+.00001:.00001
SET LAST=$ORDER(DD(FILE,DA,FIELD,LAST))
IF LAST'=+LAST
QUIT
Begin DoDot:2
+14 SET ARRAY(J)=DD(FILE,DA,FIELD,LAST)
End DoDot:2
End DoDot:1
+15 QUIT
XMB ;SEND TO WHO EVER
+1 ;THE ABOVE JUST MADE ABOVE BY WRITE
SET XMTEXT="ARRAY("
+2 SET XMSUB="NON FORMULARY REQUEST FROM "_$PIECE(^DIC(4,DUZ(2),0),U,1)
+3 SET XMDUZ=$SELECT($DATA(DUZSAVE):DUZSAVE,1:DUZ)
+4 DO ^XMD
+5 QUIT
EXIT ;CLEAN UP TIME
+1 IF $DATA(DUZSAVE)
SET DUZ=DUZSAVE
KILL DUZSAVE
+2 KILL EXIT
+3 KILL OUT,DISP
+4 KILL DDSPARM,DDSFILE,DR,DA,DDSSAVE,DDSCHANG
+5 KILL ADD,CNT,PERSON,NUM,MORE,SCR,SEQ,IEN,I,FROM,GET,DEL,HIT
+6 ;K ADD,CNT,PERSON,NUM,MORE,SCR,SEQ,IEN,I,GET,DEL,HIT
+7 KILL XMB,XMDUZ
+8 QUIT
VAL1 ;EP CALLED FROM SCREENMAN UPON VALIDATING THE FORM APSQ NF PHARMACIST
+1 ;I MIGHT NOT USE THIS
+2 ;CHECK IF RPH WANTS TO SAVE FORM
SET CHECK=$$GET^DDSVALF(8,2,1,"I")
+3 IF CHECK
Begin DoDot:1
+4 SET HELP(1)="SAVE AND EXIT THE FORM IF YOU WANT TO SAVE YOUR DATA"
+5 DO HLP^DDSUTL(.HELP)
+6 KILL DDSERROR
+7 ;S DDSBR="COM"
+8 QUIT
End DoDot:1
+9 IF 'CHECK
Begin DoDot:1
+10 SET HELP(1)="*************"
+11 SET HELP(2)="IF YOU WANT TO SAVE THE FORM"
+12 SET HELP(3)="CHANGE THE SAVE THE FORM FIELD TO 'YES'"
+13 DO HLP^DDSUTL(.HELP)
+14 KILL HELP
+15 SET DDSBR="8"
+16 SET DDSERROR=1
+17 QUIT
End DoDot:1
+18 KILL CHECK,HELP
+19 QUIT
VAL2 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE FORM
+1 SET KILL=$$GET^DDSVALF(20,1,1,"I")
+2 IF KILL
SET DIK="^APSQNF("
DO ^DIK
+3 ;K KILL,DIK,DA
+4 KILL DIK,DA
+5 QUIT
VAL3 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
+1 SET KILL=$$GET^DDSVALF(8,3,1,"I")
+2 ;
IF KILL
Begin DoDot:1
+3 SET DIE="^APSQNF("
SET DR="6///@;10///@;11///@;12///@;13///@;14///@;70///@"
DO ^DIE
+4 KILL DIE,DA
+5 QUIT
End DoDot:1
+6 KILL KILL
+7 QUIT
VAL33 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
+1 SET KILL=$$GET^DDSVALF(8,3,1,"I")
+2 ;
IF KILL
Begin DoDot:1
+3 SET HELP(1)="IF YOU WANT TO SAVE THE PHARMACIST INFORMATION"
+4 SET HELP(2)="CHANGE 'DELETE THE PHARMACY INFO AND YOUR SIGNATURE' TO 'NO'"
+5 SET HELP(3)="IF YOU WANT TO DELETE THE PHARMACIST INFO-EXIT THE FORM W/O SAVING"
+6 DO HLP^DDSUTL(.HELP)
+7 KILL HELP
+8 SET DDSBR="8"
+9 SET DDSERROR=1
+10 QUIT
End DoDot:1
+11 KILL KILL
+12 QUIT
VAL4 ;EP COME HERE FROM SCREENMAN TO SEE IF WANT TO DELETE RPH COMMENTS
+1 SET KILL=$$GET^DDSVALF(7,2,1,"I")
+2 IF KILL
Begin DoDot:1
+3 SET DIE="^APSQNF("
SET DR="7///@;7.5///@;80///@"
DO ^DIE
+4 KILL DIE,DA
+5 QUIT
End DoDot:1
+6 KILL KILL
+7 QUIT
VAL44 ;EP VALIDATION OF SCREENMAN APSQ NF PHARMACIST ...
+1 SET KILL=$$GET^DDSVALF(7,2,1,"I")
+2 IF KILL
Begin DoDot:1
+3 SET HELP(1)="IF YOU WANT TO SAVE THE P/T INFORMATION"
+4 SET HELP(2)="CHANGE 'DELETE THE P/T INFO AND YOUR SIGNATURE' TO 'NO'"
+5 SET HELP(3)="IF YOU WANT TO DELETE THE P/T INFO-EXIT THE FORM W/O SAVING"
+6 DO HLP^DDSUTL(.HELP)
+7 KILL HELP
+8 SET DDSBR="7"
+9 SET DDSERROR=1
+10 QUIT
End DoDot:1
+11 KILL KILL
+12 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 WRITE !,"CHECKING NON FORMULARY INFORMATION...",!
+4 ;I HAVEN'T A CLUE
IF ('$DATA(PSODRUG("IEN"))!('$DATA(PSODFN)))
QUIT
+5 ;NOT A NF DRUG
IF '$PIECE(^PSDRUG(PSODRUG("IEN"),0),U,9)
QUIT
+6 ;REMEMBER THIS FIELD IS VARIABLE
SET NFRXDRUG=PSODRUG("IEN")_";PSDRUG("
+7 SET NFRXPT=PSODFN
+8 SET NFRXDATE=$ORDER(^APSQNF("M",NFRXPT,NFRXDRUG,""),-1)
+9 IF 'NFRXDATE
WRITE !,"NO NON FORMULARY REQUESTS EXISTS FOR THIS DRUG"
GOTO NFRXEND
+10 SET NFRXIEN=^APSQNF("M",NFRXPT,NFRXDRUG,NFRXDATE)
+11 IF 'NFRXIEN
GOTO NFRXEND
WRITE !,"NON FORMULARY REQUEST "_$PIECE(^APSQNF(NFRXIEN,0),U)_" EXISTS"
+12 ;SECOND NODE
SET NFRXSEC=$GET(^APSQNF(NFRXIEN,1))
+13 SET NFRXREF=$PIECE(NFRXSEC,U,15)
SET NFRXAPP=$PIECE(NFRXSEC,U,8)
+14 IF NFRXREF
WRITE !,"RX# "_+$GET(^PSRX(NFRXREF,0))_" HAS BEEN FILLED PREVIOUSLY USING THIS NON FORMULARY REQUEST"
+15 WRITE !,"THIS NON FORMULARY REQUEST STATUS IS "_$SELECT(NFRXAPP=1:"APPROVED",NFRXAPP=0:"NOT APPROVED",1:"NOT ACTED UPON YET")
NFRXEND ;FINISH
+1 WRITE !
+2 DO ASK
+3 ;S:('NFRXREF)&(NFRXAPP) NFRXAOK=1
+4 DO EN^XBVK("NFRX")
+5 QUIT
ASK ;ASK WHAT IS TO BE DONE
+1 ;LETS DO REVERSE VIDEO
+2 SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+3 ;FIRST WRITE MESSAGES
+4 SET I=""
FOR
SET I=$ORDER(AZO(I))
IF I=""
QUIT
IF I="MESS"
WRITE IORVON
WRITE !,*7,AZO(I)
IF I="MESS"
WRITE IORVOFF
+5 ;S DIR("A")="WHAT IS YOUR POISON? "
+6 SET DIR("A")="WHAT IS YOUR CHOICE? "
+7 SET DIR("A",1)="1 DO YOU WANT TO DELETE THIS DRUG?"
+8 SET DIR("A",2)="2 DO AN INTERVENTION?"
+9 SET DIR("A",3)="3 DO BOTH 1 AND 2?"
+10 SET DIR("A",4)="4 JUST CONTINUE?"
+11 SET DIR("B")=1
+12 SET DIR(0)="N^1:4:0"
+13 DO ^DIR
+14 ;IF (Y="")!(Y["^") S Y=1
+15 IF $DATA(DIRUT)!($DATA(DIROUT))
SET Y=1
+16 KILL DIR,DTOUT,DIRUT,DUOUT,DIROUT
+17 DO @Y
+18 QUIT
+19 ;
1 ;DELETE THE DRUG
+1 SET PSORX("DFLG")=1
SET DGI=""
+2 QUIT
2 ;DO AN INTERVENTION
+1 SET PSORX("INTERVENE")=4
SET DGI=""
+2 ;PSORXI WAS MODIFIED
+3 ;LOOK AT THIS 4/13/98 IHS/OKCAO/POC
+4 QUIT
3 ;DO BOTH 1 AND 2
+1 DO 2
DO 1
+2 QUIT
4 ;DO NOTHING
+1 QUIT
RXSET ;EP SET THE REFERENCE RX FIELD
+1 ;CALLED FROM PSON52 AND PSOR52
+2 ;WITH NFRXIEN DEFINED AS PSRX IEN
+3 ;QUIT
+4 DO RXSET1
DO STOP
+5 QUIT
RXSET1 ;DRUG IEN
SET NFRXDRUG=$PIECE(^PSRX(NFRXIEN,0),U,6)
+1 ;NOT NON FORMULARY
IF '$PIECE(^PSDRUG(NFRXDRUG,0),U,9)
QUIT
+2 ;REMEMBER THIS FIELD IS VARIABLE
SET NFRXDRUG=NFRXDRUG_";PSDRUG("
+3 SET NFRXPT=PSODFN
+4 SET NFRXDATE=$ORDER(^APSQNF("M",NFRXPT,NFRXDRUG,""),-1)
IF NFRXDATE
SET NFRXNON=^(NFRXDATE)
+5 ;NO NON FORMULARY REQUEST
IF 'NFRXDATE
QUIT
+6 ;I HAVEN'T A CLUE
IF 'NFRXNON
QUIT
+7 ;ONLY SET IF FIELD NOT NULL
IF '$PIECE($GET(^APSQNF(NFRXNON,1)),U,15)
SET DIE="^APSQNF("
SET DA=NFRXNON
SET DR="14///"_"`"_NFRXIEN
DO ^DIE
KILL DIE
+8 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 SET KILL=$ORDER(^APSQNF("RX",NFRXIEN,""))
+4 IF KILL
SET DIE="^APSQNF("
SET DA=KILL
SET DR="14///@"
DO ^DIE
KILL DIE
+5 DO STOP
+6 QUIT
STOP DO EN^XBVK("NFRX")
+1 QUIT
