- ORNEWPERS ; NA/AJB - NEW PERSON RPC ;02/09/23 06:03
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**596**;Dec 17, 1997;Build 7
- ;
- ; External reference to $$DT^XLFDT supported by IA 10103
- ; External reference to $$ALL^VASITE suppored by IA 10112
- ; External reference to $$SCRDFCS^TIULA3 supported by IA 3976
- ; External reference to $$DIV4^XUSER supported by 2343
- ; External reference to $$PROVIDER^XUSER supported by IA 2343
- ; External reference to $$GET^XUA4A72 supported by IA 1625
- ; External reference to $$GET1^DIQ supported by IA 2056
- ; External reference to $$ACCESS^XQCHK supported by IA 10078
- ; External reference to $$NPI^XUSNPI supported by IA 4532
- ; External reference to $$ISA^USRLM supported by IA 1544
- ; External reference to $$REQCOSIG^TIULP supported by IA 2322
- ; External reference to $$ISA^USRLM supported by 1544
- ; External reference to GETLST^XPAR supported by IA 2263
- ; External reference to File ^DIC(49 supported by IA 4330
- ; External reference to File ^TIU(8925 supported by IA 2937
- ; External reference to File ^VA supported by IA 4329
- ; External reference to File ^VA supported by IA 10060
- ; External reference to File ^XUSEC supported by IA 10076
- ;
- 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
- ; similiar 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($G(^DIC(3.1,$P(NODE0,U,9),0))) ; 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 staus"
- 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 youself 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 13649 printed Feb 18, 2025@23:58:48 Page 2
- ORNEWPERS ; NA/AJB - NEW PERSON RPC ;02/09/23 06:03
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**596**;Dec 17, 1997;Build 7
- +2 ;
- +3 ; External reference to $$DT^XLFDT supported by IA 10103
- +4 ; External reference to $$ALL^VASITE suppored by IA 10112
- +5 ; External reference to $$SCRDFCS^TIULA3 supported by IA 3976
- +6 ; External reference to $$DIV4^XUSER supported by 2343
- +7 ; External reference to $$PROVIDER^XUSER supported by IA 2343
- +8 ; External reference to $$GET^XUA4A72 supported by IA 1625
- +9 ; External reference to $$GET1^DIQ supported by IA 2056
- +10 ; External reference to $$ACCESS^XQCHK supported by IA 10078
- +11 ; External reference to $$NPI^XUSNPI supported by IA 4532
- +12 ; External reference to $$ISA^USRLM supported by IA 1544
- +13 ; External reference to $$REQCOSIG^TIULP supported by IA 2322
- +14 ; External reference to $$ISA^USRLM supported by 1544
- +15 ; External reference to GETLST^XPAR supported by IA 2263
- +16 ; External reference to File ^DIC(49 supported by IA 4330
- +17 ; External reference to File ^TIU(8925 supported by IA 2937
- +18 ; External reference to File ^VA supported by IA 4329
- +19 ; External reference to File ^VA supported by IA 10060
- +20 ; External reference to File ^XUSEC supported by IA 10076
- +21 ;
- +22 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 ; similiar 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($GET(^DIC(3.1,$PIECE(NODE0,U,9),0)))
- +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 staus"
- +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 youself 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