ORNEWPERS ; NA/AJB - NEW PERSON RPC ; Sep 25, 2024@12:13:03
;;3.0;ORDER ENTRY/RESULTS REPORTING;**596,609**;Dec 17, 1997;Build 23
;
; Reference to ^DIC( in ICR #916
; Reference to ^DIC(3.1 in ICR #1234
; Reference to ^DIC(49 in ICR #4330
; Reference to ^VA(200,D0,5 in ICR #4329
; Reference to $$ISA^USRLM in ICR #1544
; Reference to $$DIV4^XUSER in ICR #2533
; Reference to $$NPI^XUSNPI in ICR #4532
; Reference to ^TIU(8925.1 in ICR #4082
; Reference to $$REQCOSIG^TIULP in ICR #2322
; Reference to $$ISA^TIULX in ICR #3058
;
Q
PARAMETERS ; FROM^DIR^KEY^DATE^RDV^ALL^PDMP^SPN^EXC^NVAP^DFC^TIUDA^TYPE^HELP^DEBUG
NEWPERSON(ORY,PARAMS) ; all parameters passed by reference
S DT=$G(DT,$$DT^XLFDT),U="^",DUZ=$G(DUZ)
N GBL,I,INF,J,MAX,P,PARAMETERS,PRM,TAG,XEC
S PARAMETERS=$P($T(PARAMETERS),"; ",2) F I=1:1:$L(PARAMETERS,U) S PRM=$P(PARAMETERS,U,I) N @(PRM) D ; setup parameters
. S (@(PRM),P(PRM))=$G(PARAMS(PRM)) ; set variables & parameters
. S INF(I,PRM)=$S($D(PARAMS(PRM)):PARAMS(PRM),1:"") ; set for help
I EXC S P("ORUCE")=$$GET^XPAR("SYS","OR CPRS USER CLASS EXCLUDE",1,"B") ; set OR CPRS USER CLASS EXCLUDE parameter
S DIR=$S('DIR:1,1:DIR),MAX=44 ; direction & max results
S GBL=$S((ALL!RDV):$NA(^VA(200,"B")),1:$NA(^VA(200,"AUSER"))) ; search global
S TAG=$S(TYPE:"COS",DFC:"DFC",PDMP:"PDM",RDV:"RDV",ALL:"ALL",1:"USR") ; tag for criteria
I TAG="COS" S P("DSC")=$$FIND1^DIC(8925.1,"","","DISCHARGE SUMMARY","","I $P(^(0),U,4)=""CL""","") ; discharge summary class
F I=0:1 S J=$P($T(@TAG+I),";;",2,3) Q:J="" S XEC(I)=J ; execution criteria [evaluated reverse order]
I HELP'=0 D HELP(.ORY,.INF,.XEC) Q ; REMOTE PROCEDURE information
; similar provider name lookup receives IEN, returns all users that match LAST,FI [ignores max limit]
; example: CPRSPROVIDER,FIRSTNAME becomes CPRSPROVIDER,FH~
I SPN N SPNQ D SPN(.FROM,.SPNQ) ; similar provider name lookup
S I=0 F Q:$S(SPN:0,1:(I'<MAX)) S FROM=$O(@GBL@(FROM),DIR) Q:$S(SPN:'(FROM[SPNQ),1:FROM="") D ; main loop
. N IEN S IEN=0 F Q:$S(SPN:0,1:I'<MAX) S IEN=$O(@GBL@(FROM,IEN)) Q:'IEN D
. . N DIV,NODE0 S NODE0=$G(^VA(200,IEN,0)) Q:NODE0="" ; set zero node
. . I PDMP D S P("DIV")=DIV ; ISAUTH^ORPDMP->$$DEA^XUSER - uses DUZ(2) of current user, not of evaluated user
. . . S DIV=$$DIV4^XUSER(.DIV,IEN) I DIV=0 S DIV="" Q ; get division(s), quit if none
. . . S DIV=$O(DIV(0))_U_$$GET1^DIQ(4,$O(DIV(0)),.01) ; set division
. . . N X S X=0 F S X=$O(DIV(X)) Q:'+X I +DIV(X) S DIV=X_U_$$GET1^DIQ(4,X,.01) ; set default division if designated
. . S P("IEN")=IEN,P("NODE0")=NODE0 ; set parameters
. . I '$$EVALUATE(.XEC,.P) Q ; evaluate user
. . N MORE S MORE=$S(SPN:1,+$O(@GBL@(FROM,IEN),1):1,+$O(@GBL@(FROM,IEN),-1):1,1:0) ; add service/section,division for user
. . S I=I+1,ORY(I)=$$DETAILS(NODE0,IEN,MORE,.DIV) ; user details
Q
EVALUATE(XEC,P) ;
N CODE,RES,VAL S RES=1,VAL="" F S VAL=$O(P(VAL)) Q:VAL="" N @(VAL) S @(VAL)=P(VAL) ; set variables
F VAL="COR","NVA" N @(VAL) S @(VAL)=$$CPRSTAB(IEN,$O(^ORD(101.13,"B",VAL,0)),DATE) ; set user CPRS TAB status
I PDMP N PDMPDIV S PDMPDIV=$G(DUZ(2)),DUZ(2)=+DIV ; ISAUTH^ORPDMP->$$DEA^XUSER - uses DUZ(2) of current user, not of evaluated user
S CODE="" F Q:'RES&('DEBUG) S CODE=$O(XEC(CODE),-1) Q:CODE="" X $P(XEC(CODE),";;") I $T D ; execute evaluation
. W:DEBUG&RES=1 !!,"Verifying "_$P(NODE0,U)_"...",!!,IOUON_"Reason(s) for exclusion"_IOUOFF
. S RES=0 W:DEBUG !,?2,@$P(XEC(CODE),";;",2) ; display exclusion description
I PDMP S DUZ(2)=PDMPDIV ; revert DUZ(2)
Q RES
SPN(FROM,SPNQ) ; similar provider name lookup
N NODE0 S NODE0=$G(^VA(200,FROM,0)) I NODE0="" S ORY(1)="-1^Invalid IEN" Q
S FROM=$P(NODE0,U),FROM=$E(FROM,1,($L($P(FROM,","))+3)),SPNQ=FROM N FNM S FNM=$P(FROM,",",2)
S $P(FROM,",",2)=$E(FNM,1,$L(FNM)-1)_$C($A(FNM,$L(FNM))-1)_"~" ; set FROM
Q
DETAILS(NODE0,IEN,MORE,DIV) ; get user information
N DTL,ENTRY S DIV=$G(DIV),DTL="",ENTRY=IEN_"^"_$$NAMEFMT^XLFNAME($P(NODE0,U),"F","DcMPC")_"^",MORE=$G(MORE,0) ; IEN^user name
S:$P(NODE0,U,9) DTL(1)=$$TITLE^XLFSTR($P($G(^DIC(3.1,$P(NODE0,U,9),0)),U)) ; title
I MORE D
. N SRV S SRV=$P($G(^VA(200,IEN,5)),U) S:SRV SRV=$$TITLE^XLFSTR($P($G(^DIC(49,SRV,0)),U)) S:SRV'="" DTL(2)=SRV ; service/section
. I +DIV S DIV=$S($P(DIV,U,2)'="":$P(DIV,U,2),1:$$GET1^DIQ(4,+DIV,.01)) S:DIV'="" DTL(3)=DIV Q ; division
. S DIV=$$DIV4^XUSER(.DIV,IEN) Q:'DIV S DIV=$$GET1^DIQ(4,$O(DIV(0)),.01) ; get division
. N X S X=0 F S X=$O(DIV(X)) Q:'+X I +DIV(X) S DIV=$$GET1^DIQ(4,X,.01) ; default division
. S:DIV'="" DTL(3)=DIV ; division
N NPI S NPI=+$$NPI^XUSNPI("Individual_ID",IEN) S:+NPI>0 DTL(4)="[NPI: "_NPI_"]" ; NPI
N X S X=0 F S X=$O(DTL(X)) Q:'X S:$O(DTL(0))=X DTL="- " S DTL=DTL_DTL(X)_$S($O(DTL(X))=4:" ",$O(DTL(X)):", ",1:"") ; set details
Q ENTRY_DTL
CPRSTAB(USER,TAB,DATE) ; return tab status
; 0 missing/expired, 1 assigned & current
N RESULT S DATE=$S(+DATE:DATE,1:DT),RESULT=0
Q:'$D(^VA(200,USER,"ORD","B",TAB)) RESULT ; quit, tab not assigned
S TAB=$O(^VA(200,USER,"ORD","B",TAB,0)) Q:'+TAB RESULT ; get tab #
S TAB=$G(^VA(200,USER,"ORD",TAB,0)) ; tab node=tab#^effective date^expiration date
I DATE'<$P(TAB,U,2),DATE<$P(TAB,U,3)!($P(TAB,U,3)="") S RESULT=1
Q RESULT
DIC(DIC) ; basic lookup
N DTOUT,DUOUT,X,Y S DIC=^DIC(DIC,0,"GL"),DIC(0)="AE" D ^DIC
Q $S(+Y>0:Y,X=U:U,+$G(DTOUT):U,Y'>0:0,1:Y)
DIR(DIR) ; basic reader
N DIRUT,DTOUT,DUOUT,X,Y D ^DIR
Q $S(+Y:Y,X=U:U,+$G(DTOUT):U,1:Y)
HELP(ORY,INF,XEC) ; return detailed parameter & user evaluation information
N GBL,I,IEN,J,NODE,X S IEN=$$FIND1^DIC(8994,,,"ORNEWPERS NEWPERSON"),X=0 Q:'IEN
F NODE=2,3 S GBL=$S(NODE=2:$NA(^XWB(8994,IEN,2,1,1)),1:$NA(^XWB(8994,IEN,3))) D
. S I=0 F S I=$O(@GBL@(I)) Q:'I S X=X+1,ORY(X)=@GBL@(I,0)
S X=X+1,ORY(X)="",X=X+1,ORY(X)="Parameter Value"
S I=0 F S I=$O(INF(I)) Q:'I S X=X+1,ORY(X)=$O(INF(I,"")),J=INF(I,$O(INF(I,""))),ORY(X)=$$SETSTR(J,ORY(X),17,$L(J))
S X=X+1,ORY(X)="",X=X+1,ORY(X)="COR=CPRS GUI ""core"" tab status",X=X+1,ORY(X)="NVA=Non-VA Providers tab status"
S X=X+1,ORY(X)="",X=X+1,ORY(X)="Current Evaluation Criteria"
S I="" F S I=$O(XEC(I),-1) Q:I="" S X=X+1,ORY(X)=$P(XEC(I),";;")
Q
SETSTR(S,V,X,L) ; insert text(S) into variable(V) at position (X) with length of (L)
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
USRCLEX(IEN,CLASS,ERR,DATE) ; NSR 20120101
Q $$ISA^USRLM(IEN,CLASS,.ERR,DATE)
; criteria to screen users, evaluated in reverse order [bottom to top]
; code;;exclusion description (debug mode)
COS ;;I $$REQCOSIG^TIULP(TYPE,TIUDA,IEN,DATE);;"User requires co-signature for a:",!,?4,$E($$GET1^DIQ(8925.1,TYPE,.01),1,67)
;;I TYPE=DSC!($$ISA^TIULX(TYPE,DSC)),'$$ISA^USRLM(IEN,"PROVIDER",,DATE);;"Not a PROVIDER User Class for a title in DISCHARGE SUMMARY Class"
DFC ;;I DFC,'$$PROVIDER^TIUPXAP1(IEN,DATE);;"Not a member of a Provider 'Person Class' for default co-signer selection"
;;I DFC,DUZ=IEN;;"Cannot assign yourself as default co-signer"
USR ;;I EXC,+ORUCE,$$USRCLEX(IEN,+ORUCE,"ERR",DATE);;"Member of "_$P(ORUCE,U,2)_" user class excluded via parameter"
;;I EXC,NVA;;"Non-VA Provider excluded for Additional Signer selection"
;;I COR,VAL=-3;;"OR CPRS GUI CHART option missing"
;;S VAL=$$ACCESS^XQCHK(IEN,"OR CPRS GUI CHART") I COR,VAL=0;;"Not assigned OR CPRS GUI CHART option [any menu tree]"
;;I 'NVAP,NVA;;"Non-VA Provider excluded via parameter"
PDM ;;I PDMP,'$$ISAUTH^ORPDMP(IEN);;"Not authorized for PDMP access"
;;I NVA,COR;;"Non-VA and 'core' CPRS TAB ACCESS "_$S(DATE:"active on "_$$FMTE^XLFDT(DATE),1:"currently active")
;;I 'NVA,'COR;;"No CPRS TAB ACCESS assigned"
;;I +$P(NODE0,U,7);;"DISUSER status YES"
RDV ;;I $P(NODE0,U,11)>0,$P(NODE0,U,11)'>$S(DATE:DATE,1:DT);;"Termination date reached "_$$FMTE^XLFDT($P(NODE0,U,11))
ALL ;;I DATE,$$GET^XUA4A72(IEN,DATE)'>0;;"No active 'Person Class' for "_$$FMTE^XLFDT(DATE)
;;I KEY'="",'$D(^XUSEC(KEY,IEN));;"Not assigned "_KEY_" Security Key"
;;
DEBUG ; evaluate a specific user, list below prompts user to determine RPC criteria entry point
;;ALL^YE^NO^Terminated or DISUSER allowed
;;RDV^YE^NO^Visitor only [for Remote Data View]
;;PDM^YE^NO^Must be authorized PDMP user
;;DFC^YE^NO^Screen for default co-signer selection
;;COS^YE^NO^Verify co-signature authorization for a document title
;;
N DIC,DIR,DIV,I,J,NODE0,P,PRM,TAG,VAL,XEC,X,Y
S DT=$G(DT,$$DT^XLFDT),U="^" D HOME^%ZIS,PREP^XGF W IOCUON
S P=$P($T(PARAMETERS),"; ",2) F I=1:1:$L(P,U) S PRM=$P(P,U,I) N @(PRM) D ; setup parameters
. S (@(PRM),P(PRM))=$G(PARAMS(PRM)) ; set variables & parameters
S DIC=200,DIC("A")="Enter NEW PERSON to evaluate: ",VAL=+$$DIC(.DIC) G EXIT:'VAL ; ask for NEW PERSON
S P("DEBUG")=1,P("IEN")=VAL,(NODE0,P("NODE0"))=^VA(200,+VAL,0)
S DIV=$$DIV4^XUSER(.DIV,VAL) D:+DIV S P("DIV")=DIV ; check division
. S DIV=$O(DIV(0))_U_$$GET1^DIQ(4,$O(DIV(0)),.01) ; set division
. N X S X=0 F S X=$O(DIV(X)) Q:'+X I +DIV(X) S DIV=X_U_$$GET1^DIQ(4,X,.01) Q ; set default division
W !!,IOUON_"Required Parameters"_IOUOFF F I=1:1 S J=$P($T(DEBUG+I),";;",2) Q:J="" D Q:VAL'="" ; prompt user from debug list
. N DIR S DIR(0)=$P(J,U,2),DIR("A")=$P(J,U,4),DIR("B")=$P(J,U,3)
. S VAL=$$DIR(.DIR) S:+VAL P($P(J,U)_$S($P(J,U)="PDM":"P",1:""))=1 S VAL=$S(+VAL:$P(J,U),VAL=U:U,1:"") ; ask & set tag for criteria
G EXIT:VAL=U S TAG=$S(VAL="":"USR",1:VAL),VAL=1 ; set criteria entry point
I TAG="COS" S DIC=8925.1,DIC("A")=" Enter a DOCUMENT DEFINITION: ",DIC("S")="I $P(^(0),U,4)=""DOC""" D K DIC ; document definition for evaluation
. S VAL=$$DIC(.DIC) Q:'VAL S P("TYPE")=+VAL ; ask for document definition
. S P("DSC")=$$FIND1^DIC(8925.1,"","","DISCHARGE SUMMARY","","I $P(^(0),U,4)=""CL""","") ; set discharge summary class
G EXIT:'VAL W !!,IOUON_"Optional Parameters"_IOUOFF
S DIC=19.1,DIC("A")="Enter a SECURITY KEY: ",VAL=$$DIC(.DIC) G EXIT:VAL=U S P("KEY")=$S(+VAL:$P(VAL,U,2),1:"") ; security key
S DIR(0)="DO",DIR("A")="Enter a DATE",VAL=$$DIR(.DIR) G EXIT:VAL=U S P("DATE")=$S(+VAL:VAL,1:"") ; date for evaluation
I $S(TAG="ALL":0,TAG="RDV":0,TAG="PDM":0,1:1) D G EXIT:VAL=U
. S DIR(0)="YE",DIR("A")="Include Non-VA Providers",DIR("B")="NO",VAL=$$DIR(.DIR) Q:VAL=U S P("NVAP")=VAL ; ask Non-VA Provider
. S DIR(0)="YE",DIR("A")="Screen for OR CPRS USER CLASS EXCLUDE parameter",DIR("B")="NO",VAL=$$DIR(.DIR) Q:VAL=U S P("EXC")=VAL ; ask parameter definition
I P("EXC") S P("ORUCE")=$$GET^XPAR("SYS","OR CPRS USER CLASS EXCLUDE",1,"B") ; set ASU class
F I=0:1 S J=$P($T(@TAG+I),";;",2,5) Q:J="" S XEC(I)=J ; execution criteria [evaluated reverse order]
S X=$$EVALUATE(.XEC,.P) W !!,$P(NODE0,U),$S(X:" would be selectable.",1:" would NOT be selectable.") ; display results
W ! K DIR S DIR(0)="E" D ^DIR
EXIT D CLEAN^XGF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORNEWPERS 12997 printed Sep 23, 2025@20:08:34 Page 2
ORNEWPERS ; NA/AJB - NEW PERSON RPC ; Sep 25, 2024@12:13:03
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**596,609**;Dec 17, 1997;Build 23
+2 ;
+3 ; Reference to ^DIC( in ICR #916
+4 ; Reference to ^DIC(3.1 in ICR #1234
+5 ; Reference to ^DIC(49 in ICR #4330
+6 ; Reference to ^VA(200,D0,5 in ICR #4329
+7 ; Reference to $$ISA^USRLM in ICR #1544
+8 ; Reference to $$DIV4^XUSER in ICR #2533
+9 ; Reference to $$NPI^XUSNPI in ICR #4532
+10 ; Reference to ^TIU(8925.1 in ICR #4082
+11 ; Reference to $$REQCOSIG^TIULP in ICR #2322
+12 ; Reference to $$ISA^TIULX in ICR #3058
+13 ;
+14 QUIT
PARAMETERS ; FROM^DIR^KEY^DATE^RDV^ALL^PDMP^SPN^EXC^NVAP^DFC^TIUDA^TYPE^HELP^DEBUG
NEWPERSON(ORY,PARAMS) ; all parameters passed by reference
+1 SET DT=$GET(DT,$$DT^XLFDT)
SET U="^"
SET DUZ=$GET(DUZ)
+2 NEW GBL,I,INF,J,MAX,P,PARAMETERS,PRM,TAG,XEC
+3 ; setup parameters
SET PARAMETERS=$PIECE($TEXT(PARAMETERS),"; ",2)
FOR I=1:1:$LENGTH(PARAMETERS,U)
SET PRM=$PIECE(PARAMETERS,U,I)
NEW @(PRM)
Begin DoDot:1
+4 ; set variables & parameters
SET (@(PRM),P(PRM))=$GET(PARAMS(PRM))
+5 ; set for help
SET INF(I,PRM)=$SELECT($DATA(PARAMS(PRM)):PARAMS(PRM),1:"")
End DoDot:1
+6 ; set OR CPRS USER CLASS EXCLUDE parameter
IF EXC
SET P("ORUCE")=$$GET^XPAR("SYS","OR CPRS USER CLASS EXCLUDE",1,"B")
+7 ; direction & max results
SET DIR=$SELECT('DIR:1,1:DIR)
SET MAX=44
+8 ; search global
SET GBL=$SELECT((ALL!RDV):$NAME(^VA(200,"B")),1:$NAME(^VA(200,"AUSER")))
+9 ; tag for criteria
SET TAG=$SELECT(TYPE:"COS",DFC:"DFC",PDMP:"PDM",RDV:"RDV",ALL:"ALL",1:"USR")
+10 ; discharge summary class
IF TAG="COS"
SET P("DSC")=$$FIND1^DIC(8925.1,"","","DISCHARGE SUMMARY","","I $P(^(0),U,4)=""CL""","")
+11 ; execution criteria [evaluated reverse order]
FOR I=0:1
SET J=$PIECE($TEXT(@TAG+I),";;",2,3)
if J=""
QUIT
SET XEC(I)=J
+12 ; REMOTE PROCEDURE information
IF HELP'=0
DO HELP(.ORY,.INF,.XEC)
QUIT
+13 ; similar provider name lookup receives IEN, returns all users that match LAST,FI [ignores max limit]
+14 ; example: CPRSPROVIDER,FIRSTNAME becomes CPRSPROVIDER,FH~
+15 ; similar provider name lookup
IF SPN
NEW SPNQ
DO SPN(.FROM,.SPNQ)
+16 ; main loop
SET I=0
FOR
if $SELECT(SPN
QUIT
SET FROM=$ORDER(@GBL@(FROM),DIR)
if $SELECT(SPN
QUIT
Begin DoDot:1
+17 NEW IEN
SET IEN=0
FOR
if $SELECT(SPN
QUIT
SET IEN=$ORDER(@GBL@(FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+18 ; set zero node
NEW DIV,NODE0
SET NODE0=$GET(^VA(200,IEN,0))
if NODE0=""
QUIT
+19 ; ISAUTH^ORPDMP->$$DEA^XUSER - uses DUZ(2) of current user, not of evaluated user
IF PDMP
Begin DoDot:3
+20 ; get division(s), quit if none
SET DIV=$$DIV4^XUSER(.DIV,IEN)
IF DIV=0
SET DIV=""
QUIT
+21 ; set division
SET DIV=$ORDER(DIV(0))_U_$$GET1^DIQ(4,$ORDER(DIV(0)),.01)
+22 ; set default division if designated
NEW X
SET X=0
FOR
SET X=$ORDER(DIV(X))
if '+X
QUIT
IF +DIV(X)
SET DIV=X_U_$$GET1^DIQ(4,X,.01)
End DoDot:3
SET P("DIV")=DIV
+23 ; set parameters
SET P("IEN")=IEN
SET P("NODE0")=NODE0
+24 ; evaluate user
IF '$$EVALUATE(.XEC,.P)
QUIT
+25 ; add service/section,division for user
NEW MORE
SET MORE=$SELECT(SPN:1,+$ORDER(@GBL@(FROM,IEN),1):1,+$ORDER(@GBL@(FROM,IEN),-1):1,1:0)
+26 ; user details
SET I=I+1
SET ORY(I)=$$DETAILS(NODE0,IEN,MORE,.DIV)
End DoDot:2
End DoDot:1
+27 QUIT
EVALUATE(XEC,P) ;
+1 ; set variables
NEW CODE,RES,VAL
SET RES=1
SET VAL=""
FOR
SET VAL=$ORDER(P(VAL))
if VAL=""
QUIT
NEW @(VAL)
SET @(VAL)=P(VAL)
+2 ; set user CPRS TAB status
FOR VAL="COR","NVA"
NEW @(VAL)
SET @(VAL)=$$CPRSTAB(IEN,$ORDER(^ORD(101.13,"B",VAL,0)),DATE)
+3 ; ISAUTH^ORPDMP->$$DEA^XUSER - uses DUZ(2) of current user, not of evaluated user
IF PDMP
NEW PDMPDIV
SET PDMPDIV=$GET(DUZ(2))
SET DUZ(2)=+DIV
+4 ; execute evaluation
SET CODE=""
FOR
if 'RES&('DEBUG)
QUIT
SET CODE=$ORDER(XEC(CODE),-1)
if CODE=""
QUIT
XECUTE $PIECE(XEC(CODE),";;")
IF $TEST
Begin DoDot:1
+5 if DEBUG&RES=1
WRITE !!,"Verifying "_$PIECE(NODE0,U)_"...",!!,IOUON_"Reason(s) for exclusion"_IOUOFF
+6 ; display exclusion description
SET RES=0
if DEBUG
WRITE !,?2,@$PIECE(XEC(CODE),";;",2)
End DoDot:1
+7 ; revert DUZ(2)
IF PDMP
SET DUZ(2)=PDMPDIV
+8 QUIT RES
SPN(FROM,SPNQ) ; similar provider name lookup
+1 NEW NODE0
SET NODE0=$GET(^VA(200,FROM,0))
IF NODE0=""
SET ORY(1)="-1^Invalid IEN"
QUIT
+2 SET FROM=$PIECE(NODE0,U)
SET FROM=$EXTRACT(FROM,1,($LENGTH($PIECE(FROM,","))+3))
SET SPNQ=FROM
NEW FNM
SET FNM=$PIECE(FROM,",",2)
+3 ; set FROM
SET $PIECE(FROM,",",2)=$EXTRACT(FNM,1,$LENGTH(FNM)-1)_$CHAR($ASCII(FNM,$LENGTH(FNM))-1)_"~"
+4 QUIT
DETAILS(NODE0,IEN,MORE,DIV) ; get user information
+1 ; IEN^user name
NEW DTL,ENTRY
SET DIV=$GET(DIV)
SET DTL=""
SET ENTRY=IEN_"^"_$$NAMEFMT^XLFNAME($PIECE(NODE0,U),"F","DcMPC")_"^"
SET MORE=$GET(MORE,0)
+2 ; title
if $PIECE(NODE0,U,9)
SET DTL(1)=$$TITLE^XLFSTR($PIECE($GET(^DIC(3.1,$PIECE(NODE0,U,9),0)),U))
+3 IF MORE
Begin DoDot:1
+4 ; service/section
NEW SRV
SET SRV=$PIECE($GET(^VA(200,IEN,5)),U)
if SRV
SET SRV=$$TITLE^XLFSTR($PIECE($GET(^DIC(49,SRV,0)),U))
if SRV'=""
SET DTL(2)=SRV
+5 ; division
IF +DIV
SET DIV=$SELECT($PIECE(DIV,U,2)'="":$PIECE(DIV,U,2),1:$$GET1^DIQ(4,+DIV,.01))
if DIV'=""
SET DTL(3)=DIV
QUIT
+6 ; get division
SET DIV=$$DIV4^XUSER(.DIV,IEN)
if 'DIV
QUIT
SET DIV=$$GET1^DIQ(4,$ORDER(DIV(0)),.01)
+7 ; default division
NEW X
SET X=0
FOR
SET X=$ORDER(DIV(X))
if '+X
QUIT
IF +DIV(X)
SET DIV=$$GET1^DIQ(4,X,.01)
+8 ; division
if DIV'=""
SET DTL(3)=DIV
End DoDot:1
+9 ; NPI
NEW NPI
SET NPI=+$$NPI^XUSNPI("Individual_ID",IEN)
if +NPI>0
SET DTL(4)="[NPI: "_NPI_"]"
+10 ; set details
NEW X
SET X=0
FOR
SET X=$ORDER(DTL(X))
if 'X
QUIT
if $ORDER(DTL(0))=X
SET DTL="- "
SET DTL=DTL_DTL(X)_$SELECT($ORDER(DTL(X))=4:" ",$ORDER(DTL(X)):", ",1:"")
+11 QUIT ENTRY_DTL
CPRSTAB(USER,TAB,DATE) ; return tab status
+1 ; 0 missing/expired, 1 assigned & current
+2 NEW RESULT
SET DATE=$SELECT(+DATE:DATE,1:DT)
SET RESULT=0
+3 ; quit, tab not assigned
if '$DATA(^VA(200,USER,"ORD","B",TAB))
QUIT RESULT
+4 ; get tab #
SET TAB=$ORDER(^VA(200,USER,"ORD","B",TAB,0))
if '+TAB
QUIT RESULT
+5 ; tab node=tab#^effective date^expiration date
SET TAB=$GET(^VA(200,USER,"ORD",TAB,0))
+6 IF DATE'<$PIECE(TAB,U,2)
IF DATE<$PIECE(TAB,U,3)!($PIECE(TAB,U,3)="")
SET RESULT=1
+7 QUIT RESULT
DIC(DIC) ; basic lookup
+1 NEW DTOUT,DUOUT,X,Y
SET DIC=^DIC(DIC,0,"GL")
SET DIC(0)="AE"
DO ^DIC
+2 QUIT $SELECT(+Y>0:Y,X=U:U,+$GET(DTOUT):U,Y'>0:0,1:Y)
DIR(DIR) ; basic reader
+1 NEW DIRUT,DTOUT,DUOUT,X,Y
DO ^DIR
+2 QUIT $SELECT(+Y:Y,X=U:U,+$GET(DTOUT):U,1:Y)
HELP(ORY,INF,XEC) ; return detailed parameter & user evaluation information
+1 NEW GBL,I,IEN,J,NODE,X
SET IEN=$$FIND1^DIC(8994,,,"ORNEWPERS NEWPERSON")
SET X=0
if 'IEN
QUIT
+2 FOR NODE=2,3
SET GBL=$SELECT(NODE=2:$NAME(^XWB(8994,IEN,2,1,1)),1:$NAME(^XWB(8994,IEN,3)))
Begin DoDot:1
+3 SET I=0
FOR
SET I=$ORDER(@GBL@(I))
if 'I
QUIT
SET X=X+1
SET ORY(X)=@GBL@(I,0)
End DoDot:1
+4 SET X=X+1
SET ORY(X)=""
SET X=X+1
SET ORY(X)="Parameter Value"
+5 SET I=0
FOR
SET I=$ORDER(INF(I))
if 'I
QUIT
SET X=X+1
SET ORY(X)=$ORDER(INF(I,""))
SET J=INF(I,$ORDER(INF(I,"")))
SET ORY(X)=$$SETSTR(J,ORY(X),17,$LENGTH(J))
+6 SET X=X+1
SET ORY(X)=""
SET X=X+1
SET ORY(X)="COR=CPRS GUI ""core"" tab status"
SET X=X+1
SET ORY(X)="NVA=Non-VA Providers tab status"
+7 SET X=X+1
SET ORY(X)=""
SET X=X+1
SET ORY(X)="Current Evaluation Criteria"
+8 SET I=""
FOR
SET I=$ORDER(XEC(I),-1)
if I=""
QUIT
SET X=X+1
SET ORY(X)=$PIECE(XEC(I),";;")
+9 QUIT
SETSTR(S,V,X,L) ; insert text(S) into variable(V) at position (X) with length of (L)
+1 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
USRCLEX(IEN,CLASS,ERR,DATE) ; NSR 20120101
+1 QUIT $$ISA^USRLM(IEN,CLASS,.ERR,DATE)
+2 ; criteria to screen users, evaluated in reverse order [bottom to top]
+3 ; code;;exclusion description (debug mode)
COS ;;I $$REQCOSIG^TIULP(TYPE,TIUDA,IEN,DATE);;"User requires co-signature for a:",!,?4,$E($$GET1^DIQ(8925.1,TYPE,.01),1,67)
+1 ;;I TYPE=DSC!($$ISA^TIULX(TYPE,DSC)),'$$ISA^USRLM(IEN,"PROVIDER",,DATE);;"Not a PROVIDER User Class for a title in DISCHARGE SUMMARY Class"
DFC ;;I DFC,'$$PROVIDER^TIUPXAP1(IEN,DATE);;"Not a member of a Provider 'Person Class' for default co-signer selection"
+1 ;;I DFC,DUZ=IEN;;"Cannot assign yourself as default co-signer"
USR ;;I EXC,+ORUCE,$$USRCLEX(IEN,+ORUCE,"ERR",DATE);;"Member of "_$P(ORUCE,U,2)_" user class excluded via parameter"
+1 ;;I EXC,NVA;;"Non-VA Provider excluded for Additional Signer selection"
+2 ;;I COR,VAL=-3;;"OR CPRS GUI CHART option missing"
+3 ;;S VAL=$$ACCESS^XQCHK(IEN,"OR CPRS GUI CHART") I COR,VAL=0;;"Not assigned OR CPRS GUI CHART option [any menu tree]"
+4 ;;I 'NVAP,NVA;;"Non-VA Provider excluded via parameter"
PDM ;;I PDMP,'$$ISAUTH^ORPDMP(IEN);;"Not authorized for PDMP access"
+1 ;;I NVA,COR;;"Non-VA and 'core' CPRS TAB ACCESS "_$S(DATE:"active on "_$$FMTE^XLFDT(DATE),1:"currently active")
+2 ;;I 'NVA,'COR;;"No CPRS TAB ACCESS assigned"
+3 ;;I +$P(NODE0,U,7);;"DISUSER status YES"
RDV ;;I $P(NODE0,U,11)>0,$P(NODE0,U,11)'>$S(DATE:DATE,1:DT);;"Termination date reached "_$$FMTE^XLFDT($P(NODE0,U,11))
ALL ;;I DATE,$$GET^XUA4A72(IEN,DATE)'>0;;"No active 'Person Class' for "_$$FMTE^XLFDT(DATE)
+1 ;;I KEY'="",'$D(^XUSEC(KEY,IEN));;"Not assigned "_KEY_" Security Key"
+2 ;;
DEBUG ; evaluate a specific user, list below prompts user to determine RPC criteria entry point
+1 ;;ALL^YE^NO^Terminated or DISUSER allowed
+2 ;;RDV^YE^NO^Visitor only [for Remote Data View]
+3 ;;PDM^YE^NO^Must be authorized PDMP user
+4 ;;DFC^YE^NO^Screen for default co-signer selection
+5 ;;COS^YE^NO^Verify co-signature authorization for a document title
+6 ;;
+7 NEW DIC,DIR,DIV,I,J,NODE0,P,PRM,TAG,VAL,XEC,X,Y
+8 SET DT=$GET(DT,$$DT^XLFDT)
SET U="^"
DO HOME^%ZIS
DO PREP^XGF
WRITE IOCUON
+9 ; setup parameters
SET P=$PIECE($TEXT(PARAMETERS),"; ",2)
FOR I=1:1:$LENGTH(P,U)
SET PRM=$PIECE(P,U,I)
NEW @(PRM)
Begin DoDot:1
+10 ; set variables & parameters
SET (@(PRM),P(PRM))=$GET(PARAMS(PRM))
End DoDot:1
+11 ; ask for NEW PERSON
SET DIC=200
SET DIC("A")="Enter NEW PERSON to evaluate: "
SET VAL=+$$DIC(.DIC)
if 'VAL
GOTO EXIT
+12 SET P("DEBUG")=1
SET P("IEN")=VAL
SET (NODE0,P("NODE0"))=^VA(200,+VAL,0)
+13 ; check division
SET DIV=$$DIV4^XUSER(.DIV,VAL)
if +DIV
Begin DoDot:1
+14 ; set division
SET DIV=$ORDER(DIV(0))_U_$$GET1^DIQ(4,$ORDER(DIV(0)),.01)
+15 ; set default division
NEW X
SET X=0
FOR
SET X=$ORDER(DIV(X))
if '+X
QUIT
IF +DIV(X)
SET DIV=X_U_$$GET1^DIQ(4,X,.01)
QUIT
End DoDot:1
SET P("DIV")=DIV
+16 ; prompt user from debug list
WRITE !!,IOUON_"Required Parameters"_IOUOFF
FOR I=1:1
SET J=$PIECE($TEXT(DEBUG+I),";;",2)
if J=""
QUIT
Begin DoDot:1
+17 NEW DIR
SET DIR(0)=$PIECE(J,U,2)
SET DIR("A")=$PIECE(J,U,4)
SET DIR("B")=$PIECE(J,U,3)
+18 ; ask & set tag for criteria
SET VAL=$$DIR(.DIR)
if +VAL
SET P($PIECE(J,U)_$SELECT($PIECE(J,U)="PDM":"P",1:""))=1
SET VAL=$SELECT(+VAL:$PIECE(J,U),VAL=U:U,1:"")
End DoDot:1
if VAL'=""
QUIT
+19 ; set criteria entry point
if VAL=U
GOTO EXIT
SET TAG=$SELECT(VAL="":"USR",1:VAL)
SET VAL=1
+20 ; document definition for evaluation
IF TAG="COS"
SET DIC=8925.1
SET DIC("A")=" Enter a DOCUMENT DEFINITION: "
SET DIC("S")="I $P(^(0),U,4)=""DOC"""
Begin DoDot:1
+21 ; ask for document definition
SET VAL=$$DIC(.DIC)
if 'VAL
QUIT
SET P("TYPE")=+VAL
+22 ; set discharge summary class
SET P("DSC")=$$FIND1^DIC(8925.1,"","","DISCHARGE SUMMARY","","I $P(^(0),U,4)=""CL""","")
End DoDot:1
KILL DIC
+23 if 'VAL
GOTO EXIT
WRITE !!,IOUON_"Optional Parameters"_IOUOFF
+24 ; security key
SET DIC=19.1
SET DIC("A")="Enter a SECURITY KEY: "
SET VAL=$$DIC(.DIC)
if VAL=U
GOTO EXIT
SET P("KEY")=$SELECT(+VAL:$PIECE(VAL,U,2),1:"")
+25 ; date for evaluation
SET DIR(0)="DO"
SET DIR("A")="Enter a DATE"
SET VAL=$$DIR(.DIR)
if VAL=U
GOTO EXIT
SET P("DATE")=$SELECT(+VAL:VAL,1:"")
+26 IF $SELECT(TAG="ALL":0,TAG="RDV":0,TAG="PDM":0,1:1)
Begin DoDot:1
+27 ; ask Non-VA Provider
SET DIR(0)="YE"
SET DIR("A")="Include Non-VA Providers"
SET DIR("B")="NO"
SET VAL=$$DIR(.DIR)
if VAL=U
QUIT
SET P("NVAP")=VAL
+28 ; ask parameter definition
SET DIR(0)="YE"
SET DIR("A")="Screen for OR CPRS USER CLASS EXCLUDE parameter"
SET DIR("B")="NO"
SET VAL=$$DIR(.DIR)
if VAL=U
QUIT
SET P("EXC")=VAL
End DoDot:1
if VAL=U
GOTO EXIT
+29 ; set ASU class
IF P("EXC")
SET P("ORUCE")=$$GET^XPAR("SYS","OR CPRS USER CLASS EXCLUDE",1,"B")
+30 ; execution criteria [evaluated reverse order]
FOR I=0:1
SET J=$PIECE($TEXT(@TAG+I),";;",2,5)
if J=""
QUIT
SET XEC(I)=J
+31 ; display results
SET X=$$EVALUATE(.XEC,.P)
WRITE !!,$PIECE(NODE0,U),$SELECT(X:" would be selectable.",1:" would NOT be selectable.")
+32 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT DO CLEAN^XGF
+1 QUIT
