PSOPRVW ;BIR/SAB,MHA-enter/edit/view provider ;3/10/22 16:20
;;7.0;OUTPATIENT PHARMACY;**11,146,153,263,268,264,398,391,450,630,545,731,743,762**;DEC 1997;Build 3
;
;Ref. to ^VA(200 supp. by IA 224
;Ref. to ^DIC(7 supp. by IA 491
;Ref. to $$NPI^XUSNPI supp. by IA 4532
;Ref. to XUSERNEW supp. by 10053
;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;
START W ! S DIC("A")="Select Provider: ",DIC("S")="I $D(^VA(200,+Y,""PS""))",DIC="^VA(200,",DIC(0)="AEQMZ" D ^DIC G:U[X EX G:Y<0 START K DIC S PRNO=+Y
;N PSOMARG,PRVNMLBL
;S PSOMARG=$S($G(IOM):$G(IOM)-6,1:74)
;W:$D(IOF) @IOF
;S PRVNMLBL="NAME: "_$P($G(^VA(200,PRNO,0)),"^")
;W !?((PSOMARG/2)-($L(PRVNMLBL)/2)),PRVNMLBL,!
;W @IOF,?2,"NAME: "_$P(^VA(200,PRNO,0),U) G:$$CHKP START
;I +$P(^VA(200,PRNO,"PS"),U,4),$P(^("PS"),U,4)'>DT W ?40,$C(7),"* * * INACTIVE AS OF ",$E($P(^("PS"),U,4),4,5),"/",$E($P(^("PS"),U,4),6,7),"/",$E($P(^("PS"),U,4),2,3)," * * *"
;W !?2,"INITIALS: "_$P(^VA(200,PRNO,0),U,2)
D PRNAMDSP(PRNO)
D DISPLAY(PRNO)
G START
EX K DIC,DIE,DA,DR,D0,PRNO,PRCLS,STAT,T,Y,X,L,LF,I,DIR,DIROUT,DUOUT,DTOUT,DIRUT,%,%Y,%W,%Z,C,DDH,DI,DIH,DLAYGO,DQ,X1,XMDT,XMN
Q
ASK ;edit providers
K DIR,DTOUT,DUOUT,DIROUT,DIRUT,FMG,FMGO,FMGX,MSG,EXIT S EXIT=0
W !! S DIC("A")="Select Provider: ",(DIC,DIE)=200,DIC(0)="AEQMZ" D ^DIC G:U[X EX G:Y<0 ASK S (FADA,DA)=+Y
I '$D(^VA(200,DA,"PS")) G NPRV
ASK1 ; Prompt for provider
;N PSOMARG,PRVNMLBL
;S PSOMARG=$S($G(IOM):$G(IOM)-6,1:74)
;W:$D(IOF) @IOF
;S PRVNMLBL="NAME: "_$P($G(^VA(200,DA,0)),"^")
;W !?((PSOMARG/2)-($L(PRVNMLBL)/2)),PRVNMLBL,! G:$$CHKP START
D PRNAMDSP(DA)
D DISPLAY(DA) G:$G(EXIT) START
EDT W ! L +^VA(200,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
I '$T W $C(7),!!,"Provider Data is Being Edited by Another User!",! G QX
N RTPB S RTPB=$G(^VA(200,DA,"TPB"))
N PSOPOM S PSOPOM=$$GET1^DIQ(59.7,1,102,"I") ; JCH-PSO*7*630; Pharmacy Operating Mode=MBM or VAMC
S DR="53.91;53.6" D ^DIE I $D(Y)!$D(DTOUT) G QX ; JCH-PSO*7*630; Prompt for PROVIDER TYPE after NON-VA
I '$$GET1^DIQ(200,DA,53.91,"I"),$G(PSOTPBFG) G QX
I $$GET1^DIQ(200,DA,53.91,"I") S DR="53.92R;53.93R;53.94R;53.95R"
E S DR="53.92;53.93;53.94;53.95"
S DR=DR_";D:X MS^PSOPRVW",DIE("NO^")="OUTOK" D ^DIE K DIE("NO^")
I '$D(^VA(200,DA,"TPB")),$G(PSOTPBFG) G QX
I $D(Y)!$D(DTOUT) D:$P($G(^VA(200,DA,"TPB")),U,3) G QX
.I RTPB=""!('$P(RTPB,U,3)) S DR="53.96////"_DUZ D ^DIE
I $P($G(^VA(200,DA,"TPB")),U,3) D
.I RTPB=""!('$P(RTPB,U,3)) S DR="53.96////"_DUZ D ^DIE
N PSORTPB S PSORTPB=$G(^VA(200,DA,"TPB"))
I $P(PSORTPB,U,4)'=$P(RTPB,U,4)!($P(PSORTPB,U,5)'=$P(RTPB,U,5)) D
.S DR="53.96////"_DUZ D ^DIE
G:$G(PSOTPBFG) QX
; PSO*7*630; Move PROVIDER TYPE (53.6), DETOX/MAINTENANCE ID NUMBER to after check of PROVIDER TYPE and NON-VA PRESCRIBER
ED1 ; Edit provider
S DR="53.1"
S DIE("NO^")="OUTOK" D ^DIE I $D(Y)!$D(DTOUT) G QX
D DEAEDT^PSOPRVW1(DA)
D VANUMEDT(DA) I $D(DTOUT) K DTOUT G QX
S DR="53.4;53.5;D DR1^PSOPRVW"
S DR(1,200,1)="D DR1^PSOPRVW" ;Just a place holder PSO*7.0*450
S DIE("NO^")="OUTOK" D ^DIE K DIE("NO^") S FADA=DA D:'$D(Y) KEY
QX K FADA,RTPB,PSORTPB L -^VA(200,DA) Q:$G(PSOTPBFG) K DR,DIC,DIQ G:+$G(VADA) ADD G ASK
Q
G:'$D(^VA(200,DA,"TPB")) ED1
ADD ;add new providers (kernel 7)
N PSDRSTR N VADA ;,PSOPX
S PSDRSTR="53.91;53.6;S:'($$GET1^DIQ(200,DA,53.91,""I"")) Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;"
W ! S VADA=$$ADD^XUSERNEW(PSDRSTR)
S (FADA,DA)=+VADA,(DIC,DIE)="^VA(200,"
I VADA>0,$P(VADA,U,3) D
. D DEAEDT^PSOPRVW1(DA)
. D VANUMEDT(DA) I $D(DTOUT) K DTOUT Q
. K DR I $$EDITCHK^PSOPRVW(+$G(FADA)) S DR="29;8932.1;"
. S DR=$G(DR)_"53.4;53.5;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141"
. D ^DIE
I VADA>0,$P(VADA,U,3),$P($G(^VA(200,DA,"TPB")),U) D
.S DR="53.96////"_DUZ S DIE("NO^")="OUTOK" D ^DIE
I VADA>0,'$P(VADA,U,3) S DIC(0)="AEQMZ" G:'$D(^VA(200,+VADA,"PS")) NPRV G:$D(^VA(200,+VADA,"PS")) ASK1
I VADA>0 D KEY K DIK,DIC,Y,X,VADA,VA,DEA Q:$G(PSOTPBFG) K DA D EX G ADD
Q
NPRV W ! S DIR("A",1)=$P(^VA(200,DA,0),U)_" is NOT currently indicated as being a provider.",DIR("A")="Do you want to make "_$P(^VA(200,DA,0),U)_" a provider? (Y/N): ",DIR(0)="SA^1:YES;0:NO",DIR("B")="NO"
S DIR("?",1)="Answer with '1' or 'Yes' if "_$P(^VA(200,DA,0),U)_" is to become a provider",DIR("?")="otherwise press return for 'No' and re-enter name." D ^DIR G:$D(DTOUT) EX
G:'Y!($D(DIRUT))&('+$G(VADA)) ASK G:'$P(+$G(VADA),U,3)&('Y) ADD
G EDT
Q
KEY I $D(^VA(200,DA,"PS")) D
.I '$P(^VA(200,DA,"PS"),U,4)!($P(^("PS"),U,4)>DT) S PSOPDA=DA K DIC S DIC="^DIC(19.1,",DIC(0)="MZ",X="PROVIDER" D ^DIC K DIC S DA=PSOPDA K PSOPDA I +Y>0 S X=+Y D
..S:'$D(^VA(200,FADA,51,0)) ^VA(200,FADA,51,0)=U_$P(^DD(200,51,0),U,2)_"^^"
..S DIC="^VA(200,"_FADA_",51,",DIC(0)="LM",DIC("DR")="1////"_$S($G(DUZ):DUZ,1:"")_";2///"_DT,DLAYGO=200.051,DINUM=X,DA(1)=FADA
..L +^VA(200,FADA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) K DD,DO D FILE^DICN L -^VA(200,FADA) K DIC,DR,X,Y
Q
MS ;
W !!,$C(7),"This provider will not be selectable during TPB medication order entry!!",!
Q
DR1 ;Added for processing of JUMP correctly PSO*7.0*450
; PSO*7*630; Use PROVIDER TYPE that was filed into $P(^VA(200,DA,"PS"),U,6), not X. The last field has been re-requenced, so can't rely on local X at this point.
N PSOPX S PSOPX=$$GET1^DIQ(200,+$G(DA),53.6,"I")
I PSOPX'?1N!(PSOPX'>0)!(PSOPX'<6) Q
I $$EDITCHK(+$G(DA)) D Q ; PROVIDER TYPE="C&A"or"FEE BASIS" -OR- NON-VA PRESCRIBER="YES"
.N TMPDR S TMPDR="D DR1^PSOPRVW;S Y=""@1"";53.1;53.3;53.4;53.5;@1;29;8932.1;53.7;"
.S (DR,DR(1),DR(1,200,1))=TMPDR_"I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141" ;_";53.1;53.3:53.5"
S (DR,DR(1),DR(1,200,1))="D DR1^PSOPRVW;S Y=""@1"";53.1;53.3;53.4;53.5;@1;53.7;I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141"
Q
CHKP(ROWPAD) ; Check for End Of Page
N X,Y,DTOUT,DUOUT,DIRUT,DIR,RESPONSE S RESPONSE=0
S:'$G(ROWPAD) ROWPAD=6
I $Y>(IOSL-ROWPAD) S DIR(0)="E" D ^DIR S:$D(DIRUT) RESPONSE=1 W @IOF D PRNAMDSP(PRNO)
Q RESPONSE
VANUMEDT(DA) ; -- Code used to add/edit/delete the VA Number
N ACNT,DIE,DIR,DR,X,Y
VANUMEDC ; -- Loop Continuation Point
S DIR(0)="200,53.3" D ^DIR
I $G(X)="^" S DTOUT=1 Q
I $G(X)["^" W !,$C(7)," No Jumping allowed??" G VANUMEDC
I $G(X)="@" D Q
. S DIR("A")="DO YOU STILL WANT TO DELETE THIS VA NUMBER"
. S ACNT=0
. S ACNT=ACNT+1,DIR("A",ACNT)="Removing the VA number does not affect previously written prescriptions."
. I '$$NPDEACNT^PSOPRVW1(DA) D
.. S ACNT=ACNT+1,DIR("A",ACNT)="There are no DEA#'s on file for this provider. The provider will no"
.. S ACNT=ACNT+1,DIR("A",ACNT)="longer be able to prescribe controlled substances at the VA."
. S ACNT=ACNT+1,DIR("A",ACNT)=" "
. S DIR(0)="Y" D ^DIR
. I Y=1 S DIE="^VA(200,",DR="53.3///@" D ^DIE Q
;S DIE="^VA(200,",DR="53.3////"_X D ^DIE
N FDA S FDA(200,DA_",",53.3)=X D FILE^DIE("","FDA","MSGROOT")
Q
;
EDITCHK(PSOPRDA) ; Check fields to enable editing of DETOX NUMBER , EXPIRATION DATE , SERVICE/SECTION (29), PERSON CLASS (8932.1), SCHEDULES
; INPUT: PSOPRDA = Provider DUZ
N PROVTYP K EDCHKRET S EDCHKRET="000"
I '$L($$GET1^DIQ(200,PSOPRDA,.01)) Q ""
I $$POM="MBM" S $E(EDCHKRET)=1
I $$GET1^DIQ(200,PSOPRDA,53.91,"I") S $E(EDCHKRET,2)=1
S PROVTYP=$$GET1^DIQ(200,PSOPRDA,53.6,"I")
I PROVTYP=3!(PROVTYP=4) S $E(EDCHKRET,3)=1
Q EDCHKRET
;
DISPLAY(PRNO) ; Display Provider Info from NEW PERSON file (#200)
; Input: PRNO - Provider IEN from NEW PERSON file (#200)
N PSAR,PSDATA S EXIT=0
W ?2,"NAME: "_$P(^VA(200,PRNO,0),U)
D GETS^DIQ(200,PRNO,53.4,"IE","PSINACT")
S PSINACTE=$G(PSINACT(200,PRNO_",",53.4,"E"))
S PSINACTI=$G(PSINACT(200,PRNO_",",53.4,"I"))
W !?2,"INITIALS: "_$P(^VA(200,PRNO,0),"^",2) I PSINACTI D
.I PSINACTI>DT W ?40,"INACTIVE DATE: ",PSINACTE
.I PSINACTI'>DT W ?40,$C(7),"*** INACTIVE AS OF ",PSINACTE," ***"
N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",PRNO),U) S NPI=$S(NPI>0:+NPI,1:"")
D GETS^DIQ(200,PRNO,"53.91;53.92;53.93;53.94;53.95;53.96","E","PSAR")
N PSLINE D LINEP(PRNO,.PSAR,53.91,,53.92),LINEP(PRNO,.PSAR,53.93,,53.95),LINEP(PRNO,.PSAR,53.94),LINEP(PRNO,.PSAR,53.96)
D GETS^DIQ(200,PRNO,"29;53.1;53.3;53.4;53.5;53.6;53.7;53.8;53.9;55.1;55.2;55.3;55.4;55.5;55.6;.111;.112;.113;.114;.115;.116;.131;.132;.133;.134;.136;.137;.138;.141","E","PSAR")
; Don't print lines with no Data
N PSLINE D LINEP(PRNO,.PSAR,53.1) ; "Authorized to Write Med Orders"
;
; PSO*7*545 - Multiple DEA Enhancements
N NPDEAIEN,DNDEAIEN,EXIT
W ! G:$$CHKP START
N SET,SETARRAY,LINE S SET=0
S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,PRNO,"PS4",NPDEAIEN)) Q:'+NPDEAIEN D
. N PSODOJE
. S DNDEAIEN=$P(^VA(200,PRNO,"PS4",NPDEAIEN,0),U,3) Q:DNDEAIEN=""
. S PSODOJE=$G(^XTV(8991.9,DNDEAIEN,0)) Q:PSODOJE=""
. S SET=SET+1,LINE=0
. S LINE=LINE+1,SETARRAY(SET,LINE)="DEA NUMBER: "_$P(PSODOJE,U,1)
. S:$P(^VA(200,PRNO,"PS4",NPDEAIEN,0),U,2)'="" SETARRAY(SET,LINE)=SETARRAY(SET,LINE)_"-"_$P(^VA(200,PRNO,"PS4",NPDEAIEN,0),U,2)
. S LINE=LINE+1,SETARRAY(SET,LINE)="DEA EXPIRATION DATE: " S T=+$P(^XTV(8991.9,DNDEAIEN,0),U,4) S:T SETARRAY(SET,LINE)=SETARRAY(SET,LINE)_$$FMTE^XLFDT(T)
. S LINE=LINE+1,SETARRAY(SET,LINE)=" USE FOR INPATIENT ORDERS: " S T=+$P(^XTV(8991.9,DNDEAIEN,0),U,6) S SETARRAY(SET,LINE)=SETARRAY(SET,LINE)_$S(T:"YES",1:"NO")
. ;P731 detox/x-waiver removal
. ;S:$P(^XTV(8991.9,DNDEAIEN,0),U,3)'="" LINE=LINE+1,SETARRAY(SET,LINE)=" DETOX NUMBER: "_$P(^XTV(8991.9,DNDEAIEN,0),U,3)
. N SCHNODE S SCHNODE=$G(^XTV(8991.9,DNDEAIEN,2)) D:SCHNODE'=""
.. I $$GET1^DIQ(8991.9,DNDEAIEN,.07)="INSTITUTIONAL" S SCHNODE=$G(^VA(200,PRNO,"PS3"))
.. S LINE=LINE+1,SETARRAY(SET,LINE)=" SCHEDULE II NARCOTIC: "_$S($P(SCHNODE,U,1):"YES",1:"NO")
.. S LINE=LINE+1,SETARRAY(SET,LINE)=" SCHEDULE II NON-NARCOTIC: "_$S($P(SCHNODE,U,2):"YES",1:"NO")
.. S LINE=LINE+1,SETARRAY(SET,LINE)=" SCHEDULE III NARCOTIC: "_$S($P(SCHNODE,U,3):"YES",1:"NO")
.. S LINE=LINE+1,SETARRAY(SET,LINE)=" SCHEDULE III NON-NARCOTIC: "_$S($P(SCHNODE,U,4):"YES",1:"NO")
.. S LINE=LINE+1,SETARRAY(SET,LINE)=" SCHEDULE IV: "_$S($P(SCHNODE,U,5):"YES",1:"NO")
.. S LINE=LINE+1,SETARRAY(SET,LINE)=" SCHEDULE V: "_$S($P(SCHNODE,U,6):"YES",1:"NO")
. S:'$D(SETARRAY(SET,10)) SETARRAY(SET,10)=""
;
;Print DEA data
;PSO*7*762 change to CHKP(12)
S EXIT=0
F SET=1:2:$O(SETARRAY(100),-1) Q:($G(EXIT)=1) D
. W ! I $$CHKP(12) S EXIT=1 Q
. F LINE=1:1:10 Q:EXIT D
.. Q:'$D(SETARRAY(SET)) ; Should never happen - IEN in 200.5321 doesn't exist in 8991.9
.. W SETARRAY(SET,LINE),?40,$G(SETARRAY(SET+1,LINE)),!
.. I SETARRAY(SET,LINE)="" I $$CHKP(12) S EXIT=1 Q
K SETARRAY,SET,LINE
Q:EXIT=1 W ! I $$CHKP(20) S EXIT=1 Q
;
D LINEP(PRNO,.PSAR,53.3,,53.5) I $$CHKP S EXIT=1 Q ; VA# and Provider Class
N HASVANO
S HASVANO=$$DEA^XUSER(1,PRNO)
I HASVANO'="",HASVANO=$$GET1^DIQ(200,PRNO,53.3,"I") D SKED200
D LINEP(PRNO,.PSAR,53.6,,,$S($L($G(NPI)):"NPI",1:""),,,$S($L($G(NPI)):NPI,1:"")) I $$CHKP S EXIT=1 Q ; Provider Type
D LINEP(PRNO,.PSAR,53.7,,53.8) I $$CHKP S EXIT=1 Q ; Cosigners
D LINEP(PRNO,.PSAR,53.9) I $$CHKP S EXIT=1 Q
W !?2,"SYNONYM(S): "_$S($P($G(^VA(200,PRNO,.1)),U,4)]"":$P(^(.1),U,4)_",",1:"")_$S($P(^(0),U,2)]"":" "_$P(^(0),U,2),1:"") I $$CHKP S EXIT=1 Q
W !?2,"SERVICE/SECTION: "_$G(PSAR(200,PRNO_",",29,"E")) I $$CHKP S EXIT=1 Q
W ! D LINEP(PRNO,.PSAR,.111,,.112),LINEP(PRNO,.PSAR,.113,,.114),LINEP(PRNO,.PSAR,.115,,.116) I $$CHKP S EXIT=1 Q
D LINEP(PRNO,.PSAR,.131,,.132),LINEP(PRNO,.PSAR,.133,,.134),LINEP(PRNO,.PSAR,.136,,.137),LINEP(PRNO,.PSAR,.138,,.141)
K DIC,Y
Q
SKED200 ;
N SKED200 S SKED200=$G(^VA(200,PRNO,"PS3")) D:SKED200'=""
. W !," SCHEDULE II NARCOTIC: "_$S($P(SKED200,U,1):"YES",1:"NO")
. W !," SCHEDULE II NON-NARCOTIC: "_$S($P(SKED200,U,2):"YES",1:"NO")
. W !," SCHEDULE III NARCOTIC: "_$S($P(SKED200,U,3):"YES",1:"NO")
. W !," SCHEDULE III NON-NARCOTIC: "_$S($P(SKED200,U,4):"YES",1:"NO")
. W !," SCHEDULE IV: "_$S($P(SKED200,U,5):"YES",1:"NO")
. W !," SCHEDULE V: "_$S($P(SKED200,U,6):"YES",1:"NO")
. W !,""
Q
LINEP(DA,PSAR,F1,L1,F2,L2,DSPNUL,V1,V2) ; Print Line
; Input: DA - Provider IEN from NEW PERSON file (#200). (required)
; PSAR - Array returned from GETS^DIQ(200,DA. (required)
; F1 - Field number from NEW PERSON file (#200) to display in left column. (required)
; L1 - Label text to display with F1 field. (optional-label from ^DD(200 will be used if not passed).
; F2 - Field number from NEW PERSON file (#200) to display in right column. (optional)
; L2 - Label text to display with F2 field. (optional-label from ^DD(200 will be used if not passed).
; DSPNUL - Display Null data - 1:Only applies to first column/field, 2:Only applies to second column/field, 3: Both fields
; V1 - Constant value to be displayed with label 1
; V2 - Constant value to be displayed with label 2
N PSDATA1,PSDATA2,LB1,LB2
S PSDATA1="",PSDATA2="",LB1=$G(L1),LB2=$G(L2),DSPNUL=$G(DSPNUL),F1=$G(F1),F2=$G(F2),V1=$G(V1),V2=$G(V2)
I $L(F1) S PSDATA1=$G(PSAR(200,DA_",",F1,"E"))
I $L(F2) S PSDATA2=$G(PSAR(200,DA_",",F2,"E")) ; Get values from New Person file
I $L(V1) S PSDATA1=V1
I $L(V2) S PSDATA2=V2
I '$G(DSPNUL) Q:'$L(PSDATA1_PSDATA2) ; display null labels?
I '$L(LB1) D FIELD^DID(200,F1,,"LABEL","LABEL","ERR") S LB1=$S($L(LABEL("LABEL")):LABEL("LABEL"),1:"NO LABEL")
Q:'$L(LB1)
W !
I '$L(LB2) I $L(F2) D FIELD^DID(200,F2,,"LABEL","LABEL","ERR") S LB2=$S($L(LABEL("LABEL")):LABEL("LABEL"),1:"NO LABEL")
I $L(PSDATA1)!(DSPNUL=1)!(DSPNUL=3) W ?2,LB1_": ",PSDATA1
I $L(PSDATA2)!(DSPNUL=2)!(DSPNUL=3) W ?40,LB2_": ",PSDATA2
Q
;
POM() ; Pharmacy Operating Mode
N POM S POM=$$GET1^DIQ(59.7,1,102,"I")
Q POM
;
PRNAMDSP(PRNO) ; Display provider name and label
N PSOMARG,PRVNMLBL
S PSOMARG=$S($G(IOM):$G(IOM)-6,1:74)
W:$D(IOF) @IOF
S PRVNMLBL="NAME: "_$P($G(^VA(200,PRNO,0)),"^")
W !?((PSOMARG/2)-($L(PRVNMLBL)/2)),PRVNMLBL,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRVW 14364 printed Dec 13, 2024@02:33:07 Page 2
PSOPRVW ;BIR/SAB,MHA-enter/edit/view provider ;3/10/22 16:20
+1 ;;7.0;OUTPATIENT PHARMACY;**11,146,153,263,268,264,398,391,450,630,545,731,743,762**;DEC 1997;Build 3
+2 ;
+3 ;Ref. to ^VA(200 supp. by IA 224
+4 ;Ref. to ^DIC(7 supp. by IA 491
+5 ;Ref. to $$NPI^XUSNPI supp. by IA 4532
+6 ;Ref. to XUSERNEW supp. by 10053
+7 ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
+8 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+9 ;
START WRITE !
SET DIC("A")="Select Provider: "
SET DIC("S")="I $D(^VA(200,+Y,""PS""))"
SET DIC="^VA(200,"
SET DIC(0)="AEQMZ"
DO ^DIC
if U[X
GOTO EX
if Y<0
GOTO START
KILL DIC
SET PRNO=+Y
+1 ;N PSOMARG,PRVNMLBL
+2 ;S PSOMARG=$S($G(IOM):$G(IOM)-6,1:74)
+3 ;W:$D(IOF) @IOF
+4 ;S PRVNMLBL="NAME: "_$P($G(^VA(200,PRNO,0)),"^")
+5 ;W !?((PSOMARG/2)-($L(PRVNMLBL)/2)),PRVNMLBL,!
+6 ;W @IOF,?2,"NAME: "_$P(^VA(200,PRNO,0),U) G:$$CHKP START
+7 ;I +$P(^VA(200,PRNO,"PS"),U,4),$P(^("PS"),U,4)'>DT W ?40,$C(7),"* * * INACTIVE AS OF ",$E($P(^("PS"),U,4),4,5),"/",$E($P(^("PS"),U,4),6,7),"/",$E($P(^("PS"),U,4),2,3)," * * *"
+8 ;W !?2,"INITIALS: "_$P(^VA(200,PRNO,0),U,2)
+9 DO PRNAMDSP(PRNO)
+10 DO DISPLAY(PRNO)
+11 GOTO START
EX KILL DIC,DIE,DA,DR,D0,PRNO,PRCLS,STAT,T,Y,X,L,LF,I,DIR,DIROUT,DUOUT,DTOUT,DIRUT,%,%Y,%W,%Z,C,DDH,DI,DIH,DLAYGO,DQ,X1,XMDT,XMN
+1 QUIT
ASK ;edit providers
+1 KILL DIR,DTOUT,DUOUT,DIROUT,DIRUT,FMG,FMGO,FMGX,MSG,EXIT
SET EXIT=0
+2 WRITE !!
SET DIC("A")="Select Provider: "
SET (DIC,DIE)=200
SET DIC(0)="AEQMZ"
DO ^DIC
if U[X
GOTO EX
if Y<0
GOTO ASK
SET (FADA,DA)=+Y
+3 IF '$DATA(^VA(200,DA,"PS"))
GOTO NPRV
ASK1 ; Prompt for provider
+1 ;N PSOMARG,PRVNMLBL
+2 ;S PSOMARG=$S($G(IOM):$G(IOM)-6,1:74)
+3 ;W:$D(IOF) @IOF
+4 ;S PRVNMLBL="NAME: "_$P($G(^VA(200,DA,0)),"^")
+5 ;W !?((PSOMARG/2)-($L(PRVNMLBL)/2)),PRVNMLBL,! G:$$CHKP START
+6 DO PRNAMDSP(DA)
+7 DO DISPLAY(DA)
if $GET(EXIT)
GOTO START
EDT WRITE !
LOCK +^VA(200,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+1 IF '$TEST
WRITE $CHAR(7),!!,"Provider Data is Being Edited by Another User!",!
GOTO QX
+2 NEW RTPB
SET RTPB=$GET(^VA(200,DA,"TPB"))
+3 ; JCH-PSO*7*630; Pharmacy Operating Mode=MBM or VAMC
NEW PSOPOM
SET PSOPOM=$$GET1^DIQ(59.7,1,102,"I")
+4 ; JCH-PSO*7*630; Prompt for PROVIDER TYPE after NON-VA
SET DR="53.91;53.6"
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
GOTO QX
+5 IF '$$GET1^DIQ(200,DA,53.91,"I")
IF $GET(PSOTPBFG)
GOTO QX
+6 IF $$GET1^DIQ(200,DA,53.91,"I")
SET DR="53.92R;53.93R;53.94R;53.95R"
+7 IF '$TEST
SET DR="53.92;53.93;53.94;53.95"
+8 SET DR=DR_";D:X MS^PSOPRVW"
SET DIE("NO^")="OUTOK"
DO ^DIE
KILL DIE("NO^")
+9 IF '$DATA(^VA(200,DA,"TPB"))
IF $GET(PSOTPBFG)
GOTO QX
+10 IF $DATA(Y)!$DATA(DTOUT)
if $PIECE($GET(^VA(200,DA,"TPB")),U,3)
Begin DoDot:1
+11 IF RTPB=""!('$PIECE(RTPB,U,3))
SET DR="53.96////"_DUZ
DO ^DIE
End DoDot:1
GOTO QX
+12 IF $PIECE($GET(^VA(200,DA,"TPB")),U,3)
Begin DoDot:1
+13 IF RTPB=""!('$PIECE(RTPB,U,3))
SET DR="53.96////"_DUZ
DO ^DIE
End DoDot:1
+14 NEW PSORTPB
SET PSORTPB=$GET(^VA(200,DA,"TPB"))
+15 IF $PIECE(PSORTPB,U,4)'=$PIECE(RTPB,U,4)!($PIECE(PSORTPB,U,5)'=$PIECE(RTPB,U,5))
Begin DoDot:1
+16 SET DR="53.96////"_DUZ
DO ^DIE
End DoDot:1
+17 if $GET(PSOTPBFG)
GOTO QX
+18 ; PSO*7*630; Move PROVIDER TYPE (53.6), DETOX/MAINTENANCE ID NUMBER to after check of PROVIDER TYPE and NON-VA PRESCRIBER
ED1 ; Edit provider
+1 SET DR="53.1"
+2 SET DIE("NO^")="OUTOK"
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
GOTO QX
+3 DO DEAEDT^PSOPRVW1(DA)
+4 DO VANUMEDT(DA)
IF $DATA(DTOUT)
KILL DTOUT
GOTO QX
+5 SET DR="53.4;53.5;D DR1^PSOPRVW"
+6 ;Just a place holder PSO*7.0*450
SET DR(1,200,1)="D DR1^PSOPRVW"
+7 SET DIE("NO^")="OUTOK"
DO ^DIE
KILL DIE("NO^")
SET FADA=DA
if '$DATA(Y)
DO KEY
QX KILL FADA,RTPB,PSORTPB
LOCK -^VA(200,DA)
if $GET(PSOTPBFG)
QUIT
KILL DR,DIC,DIQ
if +$GET(VADA)
GOTO ADD
GOTO ASK
+1 QUIT
+2 if '$DATA(^VA(200,DA,"TPB"))
GOTO ED1
ADD ;add new providers (kernel 7)
+1 ;,PSOPX
NEW PSDRSTR
NEW VADA
+2 SET PSDRSTR="53.91;53.6;S:'($$GET1^DIQ(200,DA,53.91,""I"")) Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;"
+3 WRITE !
SET VADA=$$ADD^XUSERNEW(PSDRSTR)
+4 SET (FADA,DA)=+VADA
SET (DIC,DIE)="^VA(200,"
+5 IF VADA>0
IF $PIECE(VADA,U,3)
Begin DoDot:1
+6 DO DEAEDT^PSOPRVW1(DA)
+7 DO VANUMEDT(DA)
IF $DATA(DTOUT)
KILL DTOUT
QUIT
+8 KILL DR
IF $$EDITCHK^PSOPRVW(+$GET(FADA))
SET DR="29;8932.1;"
+9 SET DR=$GET(DR)_"53.4;53.5;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141"
+10 DO ^DIE
End DoDot:1
+11 IF VADA>0
IF $PIECE(VADA,U,3)
IF $PIECE($GET(^VA(200,DA,"TPB")),U)
Begin DoDot:1
+12 SET DR="53.96////"_DUZ
SET DIE("NO^")="OUTOK"
DO ^DIE
End DoDot:1
+13 IF VADA>0
IF '$PIECE(VADA,U,3)
SET DIC(0)="AEQMZ"
if '$DATA(^VA(200,+VADA,"PS"))
GOTO NPRV
if $DATA(^VA(200,+VADA,"PS"))
GOTO ASK1
+14 IF VADA>0
DO KEY
KILL DIK,DIC,Y,X,VADA,VA,DEA
if $GET(PSOTPBFG)
QUIT
KILL DA
DO EX
GOTO ADD
+15 QUIT
NPRV WRITE !
SET DIR("A",1)=$PIECE(^VA(200,DA,0),U)_" is NOT currently indicated as being a provider."
SET DIR("A")="Do you want to make "_$PIECE(^VA(200,DA,0),U)_" a provider? (Y/N): "
SET DIR(0)="SA^1:YES;0:NO"
SET DIR("B")="NO"
+1 SET DIR("?",1)="Answer with '1' or 'Yes' if "_$PIECE(^VA(200,DA,0),U)_" is to become a provider"
SET DIR("?")="otherwise press return for 'No' and re-enter name."
DO ^DIR
if $DATA(DTOUT)
GOTO EX
+2 if 'Y!($DATA(DIRUT))&('+$GET(VADA))
GOTO ASK
if '$PIECE(+$GET(VADA),U,3)&('Y)
GOTO ADD
+3 GOTO EDT
+4 QUIT
KEY IF $DATA(^VA(200,DA,"PS"))
Begin DoDot:1
+1 IF '$PIECE(^VA(200,DA,"PS"),U,4)!($PIECE(^("PS"),U,4)>DT)
SET PSOPDA=DA
KILL DIC
SET DIC="^DIC(19.1,"
SET DIC(0)="MZ"
SET X="PROVIDER"
DO ^DIC
KILL DIC
SET DA=PSOPDA
KILL PSOPDA
IF +Y>0
SET X=+Y
Begin DoDot:2
+2 if '$DATA(^VA(200,FADA,51,0))
SET ^VA(200,FADA,51,0)=U_$PIECE(^DD(200,51,0),U,2)_"^^"
+3 SET DIC="^VA(200,"_FADA_",51,"
SET DIC(0)="LM"
SET DIC("DR")="1////"_$SELECT($GET(DUZ):DUZ,1:"")_";2///"_DT
SET DLAYGO=200.051
SET DINUM=X
SET DA(1)=FADA
+4 LOCK +^VA(200,FADA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
KILL DD,DO
DO FILE^DICN
LOCK -^VA(200,FADA)
KILL DIC,DR,X,Y
End DoDot:2
End DoDot:1
+5 QUIT
MS ;
+1 WRITE !!,$CHAR(7),"This provider will not be selectable during TPB medication order entry!!",!
+2 QUIT
DR1 ;Added for processing of JUMP correctly PSO*7.0*450
+1 ; PSO*7*630; Use PROVIDER TYPE that was filed into $P(^VA(200,DA,"PS"),U,6), not X. The last field has been re-requenced, so can't rely on local X at this point.
+2 NEW PSOPX
SET PSOPX=$$GET1^DIQ(200,+$GET(DA),53.6,"I")
+3 IF PSOPX'?1N!(PSOPX'>0)!(PSOPX'<6)
QUIT
+4 ; PROVIDER TYPE="C&A"or"FEE BASIS" -OR- NON-VA PRESCRIBER="YES"
IF $$EDITCHK(+$GET(DA))
Begin DoDot:1
+5 NEW TMPDR
SET TMPDR="D DR1^PSOPRVW;S Y=""@1"";53.1;53.3;53.4;53.5;@1;29;8932.1;53.7;"
+6 ;_";53.1;53.3:53.5"
SET (DR,DR(1),DR(1,200,1))=TMPDR_"I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141"
End DoDot:1
QUIT
+7 SET (DR,DR(1),DR(1,200,1))="D DR1^PSOPRVW;S Y=""@1"";53.1;53.3;53.4;53.5;@1;53.7;I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141"
+8 QUIT
CHKP(ROWPAD) ; Check for End Of Page
+1 NEW X,Y,DTOUT,DUOUT,DIRUT,DIR,RESPONSE
SET RESPONSE=0
+2 if '$GET(ROWPAD)
SET ROWPAD=6
+3 IF $Y>(IOSL-ROWPAD)
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
SET RESPONSE=1
WRITE @IOF
DO PRNAMDSP(PRNO)
+4 QUIT RESPONSE
VANUMEDT(DA) ; -- Code used to add/edit/delete the VA Number
+1 NEW ACNT,DIE,DIR,DR,X,Y
VANUMEDC ; -- Loop Continuation Point
+1 SET DIR(0)="200,53.3"
DO ^DIR
+2 IF $GET(X)="^"
SET DTOUT=1
QUIT
+3 IF $GET(X)["^"
WRITE !,$CHAR(7)," No Jumping allowed??"
GOTO VANUMEDC
+4 IF $GET(X)="@"
Begin DoDot:1
+5 SET DIR("A")="DO YOU STILL WANT TO DELETE THIS VA NUMBER"
+6 SET ACNT=0
+7 SET ACNT=ACNT+1
SET DIR("A",ACNT)="Removing the VA number does not affect previously written prescriptions."
+8 IF '$$NPDEACNT^PSOPRVW1(DA)
Begin DoDot:2
+9 SET ACNT=ACNT+1
SET DIR("A",ACNT)="There are no DEA#'s on file for this provider. The provider will no"
+10 SET ACNT=ACNT+1
SET DIR("A",ACNT)="longer be able to prescribe controlled substances at the VA."
End DoDot:2
+11 SET ACNT=ACNT+1
SET DIR("A",ACNT)=" "
+12 SET DIR(0)="Y"
DO ^DIR
+13 IF Y=1
SET DIE="^VA(200,"
SET DR="53.3///@"
DO ^DIE
QUIT
End DoDot:1
QUIT
+14 ;S DIE="^VA(200,",DR="53.3////"_X D ^DIE
+15 NEW FDA
SET FDA(200,DA_",",53.3)=X
DO FILE^DIE("","FDA","MSGROOT")
+16 QUIT
+17 ;
EDITCHK(PSOPRDA) ; Check fields to enable editing of DETOX NUMBER , EXPIRATION DATE , SERVICE/SECTION (29), PERSON CLASS (8932.1), SCHEDULES
+1 ; INPUT: PSOPRDA = Provider DUZ
+2 NEW PROVTYP
KILL EDCHKRET
SET EDCHKRET="000"
+3 IF '$LENGTH($$GET1^DIQ(200,PSOPRDA,.01))
QUIT ""
+4 IF $$POM="MBM"
SET $EXTRACT(EDCHKRET)=1
+5 IF $$GET1^DIQ(200,PSOPRDA,53.91,"I")
SET $EXTRACT(EDCHKRET,2)=1
+6 SET PROVTYP=$$GET1^DIQ(200,PSOPRDA,53.6,"I")
+7 IF PROVTYP=3!(PROVTYP=4)
SET $EXTRACT(EDCHKRET,3)=1
+8 QUIT EDCHKRET
+9 ;
DISPLAY(PRNO) ; Display Provider Info from NEW PERSON file (#200)
+1 ; Input: PRNO - Provider IEN from NEW PERSON file (#200)
+2 NEW PSAR,PSDATA
SET EXIT=0
+3 WRITE ?2,"NAME: "_$PIECE(^VA(200,PRNO,0),U)
+4 DO GETS^DIQ(200,PRNO,53.4,"IE","PSINACT")
+5 SET PSINACTE=$GET(PSINACT(200,PRNO_",",53.4,"E"))
+6 SET PSINACTI=$GET(PSINACT(200,PRNO_",",53.4,"I"))
+7 WRITE !?2,"INITIALS: "_$PIECE(^VA(200,PRNO,0),"^",2)
IF PSINACTI
Begin DoDot:1
+8 IF PSINACTI>DT
WRITE ?40,"INACTIVE DATE: ",PSINACTE
+9 IF PSINACTI'>DT
WRITE ?40,$CHAR(7),"*** INACTIVE AS OF ",PSINACTE," ***"
End DoDot:1
+10 NEW NPI
SET NPI=$PIECE($$NPI^XUSNPI("Individual_ID",PRNO),U)
SET NPI=$SELECT(NPI>0:+NPI,1:"")
+11 DO GETS^DIQ(200,PRNO,"53.91;53.92;53.93;53.94;53.95;53.96","E","PSAR")
+12 NEW PSLINE
DO LINEP(PRNO,.PSAR,53.91,,53.92)
DO LINEP(PRNO,.PSAR,53.93,,53.95)
DO LINEP(PRNO,.PSAR,53.94)
DO LINEP(PRNO,.PSAR,53.96)
+13 DO GETS^DIQ(200,PRNO,"29;53.1;53.3;53.4;53.5;53.6;53.7;53.8;53.9;55.1;55.2;55.3;55.4;55.5;55.6;.111;.112;.113;.114;.115;.116;.131;.132;.133;.134;.136;.137;.138;.141","E","PSAR")
+14 ; Don't print lines with no Data
+15 ; "Authorized to Write Med Orders"
NEW PSLINE
DO LINEP(PRNO,.PSAR,53.1)
+16 ;
+17 ; PSO*7*545 - Multiple DEA Enhancements
+18 NEW NPDEAIEN,DNDEAIEN,EXIT
+19 WRITE !
if $$CHKP
GOTO START
+20 NEW SET,SETARRAY,LINE
SET SET=0
+21 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,PRNO,"PS4",NPDEAIEN))
if '+NPDEAIEN
QUIT
Begin DoDot:1
+22 NEW PSODOJE
+23 SET DNDEAIEN=$PIECE(^VA(200,PRNO,"PS4",NPDEAIEN,0),U,3)
if DNDEAIEN=""
QUIT
+24 SET PSODOJE=$GET(^XTV(8991.9,DNDEAIEN,0))
if PSODOJE=""
QUIT
+25 SET SET=SET+1
SET LINE=0
+26 SET LINE=LINE+1
SET SETARRAY(SET,LINE)="DEA NUMBER: "_$PIECE(PSODOJE,U,1)
+27 if $PIECE(^VA(200,PRNO,"PS4",NPDEAIEN,0),U,2)'=""
SET SETARRAY(SET,LINE)=SETARRAY(SET,LINE)_"-"_$PIECE(^VA(200,PRNO,"PS4",NPDEAIEN,0),U,2)
+28 SET LINE=LINE+1
SET SETARRAY(SET,LINE)="DEA EXPIRATION DATE: "
SET T=+$PIECE(^XTV(8991.9,DNDEAIEN,0),U,4)
if T
SET SETARRAY(SET,LINE)=SETARRAY(SET,LINE)_$$FMTE^XLFDT(T)
+29 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" USE FOR INPATIENT ORDERS: "
SET T=+$PIECE(^XTV(8991.9,DNDEAIEN,0),U,6)
SET SETARRAY(SET,LINE)=SETARRAY(SET,LINE)_$SELECT(T:"YES",1:"NO")
+30 ;P731 detox/x-waiver removal
+31 ;S:$P(^XTV(8991.9,DNDEAIEN,0),U,3)'="" LINE=LINE+1,SETARRAY(SET,LINE)=" DETOX NUMBER: "_$P(^XTV(8991.9,DNDEAIEN,0),U,3)
+32 NEW SCHNODE
SET SCHNODE=$GET(^XTV(8991.9,DNDEAIEN,2))
if SCHNODE'=""
Begin DoDot:2
+33 IF $$GET1^DIQ(8991.9,DNDEAIEN,.07)="INSTITUTIONAL"
SET SCHNODE=$GET(^VA(200,PRNO,"PS3"))
+34 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" SCHEDULE II NARCOTIC: "_$SELECT($PIECE(SCHNODE,U,1):"YES",1:"NO")
+35 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" SCHEDULE II NON-NARCOTIC: "_$SELECT($PIECE(SCHNODE,U,2):"YES",1:"NO")
+36 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" SCHEDULE III NARCOTIC: "_$SELECT($PIECE(SCHNODE,U,3):"YES",1:"NO")
+37 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" SCHEDULE III NON-NARCOTIC: "_$SELECT($PIECE(SCHNODE,U,4):"YES",1:"NO")
+38 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" SCHEDULE IV: "_$SELECT($PIECE(SCHNODE,U,5):"YES",1:"NO")
+39 SET LINE=LINE+1
SET SETARRAY(SET,LINE)=" SCHEDULE V: "_$SELECT($PIECE(SCHNODE,U,6):"YES",1:"NO")
End DoDot:2
+40 if '$DATA(SETARRAY(SET,10))
SET SETARRAY(SET,10)=""
End DoDot:1
+41 ;
+42 ;Print DEA data
+43 ;PSO*7*762 change to CHKP(12)
+44 SET EXIT=0
+45 FOR SET=1:2:$ORDER(SETARRAY(100),-1)
if ($GET(EXIT)=1)
QUIT
Begin DoDot:1
+46 WRITE !
IF $$CHKP(12)
SET EXIT=1
QUIT
+47 FOR LINE=1:1:10
if EXIT
QUIT
Begin DoDot:2
+48 ; Should never happen - IEN in 200.5321 doesn't exist in 8991.9
if '$DATA(SETARRAY(SET))
QUIT
+49 WRITE SETARRAY(SET,LINE),?40,$GET(SETARRAY(SET+1,LINE)),!
+50 IF SETARRAY(SET,LINE)=""
IF $$CHKP(12)
SET EXIT=1
QUIT
End DoDot:2
End DoDot:1
+51 KILL SETARRAY,SET,LINE
+52 if EXIT=1
QUIT
WRITE !
IF $$CHKP(20)
SET EXIT=1
QUIT
+53 ;
+54 ; VA# and Provider Class
DO LINEP(PRNO,.PSAR,53.3,,53.5)
IF $$CHKP
SET EXIT=1
QUIT
+55 NEW HASVANO
+56 SET HASVANO=$$DEA^XUSER(1,PRNO)
+57 IF HASVANO'=""
IF HASVANO=$$GET1^DIQ(200,PRNO,53.3,"I")
DO SKED200
+58 ; Provider Type
DO LINEP(PRNO,.PSAR,53.6,,,$SELECT($LENGTH($GET(NPI)):"NPI",1:""),,,$SELECT($LENGTH($GET(NPI)):NPI,1:""))
IF $$CHKP
SET EXIT=1
QUIT
+59 ; Cosigners
DO LINEP(PRNO,.PSAR,53.7,,53.8)
IF $$CHKP
SET EXIT=1
QUIT
+60 DO LINEP(PRNO,.PSAR,53.9)
IF $$CHKP
SET EXIT=1
QUIT
+61 WRITE !?2,"SYNONYM(S): "_$SELECT($PIECE($GET(^VA(200,PRNO,.1)),U,4)]"":$PIECE(^(.1),U,4)_",",1:"")_$SELECT($PIECE(^(0),U,2)]"":" "_$PIECE(^(0),U,2),1:"")
IF $$CHKP
SET EXIT=1
QUIT
+62 WRITE !?2,"SERVICE/SECTION: "_$GET(PSAR(200,PRNO_",",29,"E"))
IF $$CHKP
SET EXIT=1
QUIT
+63 WRITE !
DO LINEP(PRNO,.PSAR,.111,,.112)
DO LINEP(PRNO,.PSAR,.113,,.114)
DO LINEP(PRNO,.PSAR,.115,,.116)
IF $$CHKP
SET EXIT=1
QUIT
+64 DO LINEP(PRNO,.PSAR,.131,,.132)
DO LINEP(PRNO,.PSAR,.133,,.134)
DO LINEP(PRNO,.PSAR,.136,,.137)
DO LINEP(PRNO,.PSAR,.138,,.141)
+65 KILL DIC,Y
+66 QUIT
SKED200 ;
+1 NEW SKED200
SET SKED200=$GET(^VA(200,PRNO,"PS3"))
if SKED200'=""
Begin DoDot:1
+2 WRITE !," SCHEDULE II NARCOTIC: "_$SELECT($PIECE(SKED200,U,1):"YES",1:"NO")
+3 WRITE !," SCHEDULE II NON-NARCOTIC: "_$SELECT($PIECE(SKED200,U,2):"YES",1:"NO")
+4 WRITE !," SCHEDULE III NARCOTIC: "_$SELECT($PIECE(SKED200,U,3):"YES",1:"NO")
+5 WRITE !," SCHEDULE III NON-NARCOTIC: "_$SELECT($PIECE(SKED200,U,4):"YES",1:"NO")
+6 WRITE !," SCHEDULE IV: "_$SELECT($PIECE(SKED200,U,5):"YES",1:"NO")
+7 WRITE !," SCHEDULE V: "_$SELECT($PIECE(SKED200,U,6):"YES",1:"NO")
+8 WRITE !,""
End DoDot:1
+9 QUIT
LINEP(DA,PSAR,F1,L1,F2,L2,DSPNUL,V1,V2) ; Print Line
+1 ; Input: DA - Provider IEN from NEW PERSON file (#200). (required)
+2 ; PSAR - Array returned from GETS^DIQ(200,DA. (required)
+3 ; F1 - Field number from NEW PERSON file (#200) to display in left column. (required)
+4 ; L1 - Label text to display with F1 field. (optional-label from ^DD(200 will be used if not passed).
+5 ; F2 - Field number from NEW PERSON file (#200) to display in right column. (optional)
+6 ; L2 - Label text to display with F2 field. (optional-label from ^DD(200 will be used if not passed).
+7 ; DSPNUL - Display Null data - 1:Only applies to first column/field, 2:Only applies to second column/field, 3: Both fields
+8 ; V1 - Constant value to be displayed with label 1
+9 ; V2 - Constant value to be displayed with label 2
+10 NEW PSDATA1,PSDATA2,LB1,LB2
+11 SET PSDATA1=""
SET PSDATA2=""
SET LB1=$GET(L1)
SET LB2=$GET(L2)
SET DSPNUL=$GET(DSPNUL)
SET F1=$GET(F1)
SET F2=$GET(F2)
SET V1=$GET(V1)
SET V2=$GET(V2)
+12 IF $LENGTH(F1)
SET PSDATA1=$GET(PSAR(200,DA_",",F1,"E"))
+13 ; Get values from New Person file
IF $LENGTH(F2)
SET PSDATA2=$GET(PSAR(200,DA_",",F2,"E"))
+14 IF $LENGTH(V1)
SET PSDATA1=V1
+15 IF $LENGTH(V2)
SET PSDATA2=V2
+16 ; display null labels?
IF '$GET(DSPNUL)
if '$LENGTH(PSDATA1_PSDATA2)
QUIT
+17 IF '$LENGTH(LB1)
DO FIELD^DID(200,F1,,"LABEL","LABEL","ERR")
SET LB1=$SELECT($LENGTH(LABEL("LABEL")):LABEL("LABEL"),1:"NO LABEL")
+18 if '$LENGTH(LB1)
QUIT
+19 WRITE !
+20 IF '$LENGTH(LB2)
IF $LENGTH(F2)
DO FIELD^DID(200,F2,,"LABEL","LABEL","ERR")
SET LB2=$SELECT($LENGTH(LABEL("LABEL")):LABEL("LABEL"),1:"NO LABEL")
+21 IF $LENGTH(PSDATA1)!(DSPNUL=1)!(DSPNUL=3)
WRITE ?2,LB1_": ",PSDATA1
+22 IF $LENGTH(PSDATA2)!(DSPNUL=2)!(DSPNUL=3)
WRITE ?40,LB2_": ",PSDATA2
+23 QUIT
+24 ;
POM() ; Pharmacy Operating Mode
+1 NEW POM
SET POM=$$GET1^DIQ(59.7,1,102,"I")
+2 QUIT POM
+3 ;
PRNAMDSP(PRNO) ; Display provider name and label
+1 NEW PSOMARG,PRVNMLBL
+2 SET PSOMARG=$SELECT($GET(IOM):$GET(IOM)-6,1:74)
+3 if $DATA(IOF)
WRITE @IOF
+4 SET PRVNMLBL="NAME: "_$PIECE($GET(^VA(200,PRNO,0)),"^")
+5 WRITE !?((PSOMARG/2)-($LENGTH(PRVNMLBL)/2)),PRVNMLBL,!
+6 QUIT
