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

ORNEWPERS.m

Go to the documentation of this file.
  1. ORNEWPERS ; NA/AJB - NEW PERSON RPC ;02/09/23 06:03
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**596**;Dec 17, 1997;Build 7
  1. ;
  1. ; External reference to $$DT^XLFDT supported by IA 10103
  1. ; External reference to $$ALL^VASITE suppored by IA 10112
  1. ; External reference to $$SCRDFCS^TIULA3 supported by IA 3976
  1. ; External reference to $$DIV4^XUSER supported by 2343
  1. ; External reference to $$PROVIDER^XUSER supported by IA 2343
  1. ; External reference to $$GET^XUA4A72 supported by IA 1625
  1. ; External reference to $$GET1^DIQ supported by IA 2056
  1. ; External reference to $$ACCESS^XQCHK supported by IA 10078
  1. ; External reference to $$NPI^XUSNPI supported by IA 4532
  1. ; External reference to $$ISA^USRLM supported by IA 1544
  1. ; External reference to $$REQCOSIG^TIULP supported by IA 2322
  1. ; External reference to $$ISA^USRLM supported by 1544
  1. ; External reference to GETLST^XPAR supported by IA 2263
  1. ; External reference to File ^DIC(49 supported by IA 4330
  1. ; External reference to File ^TIU(8925 supported by IA 2937
  1. ; External reference to File ^VA supported by IA 4329
  1. ; External reference to File ^VA supported by IA 10060
  1. ; External reference to File ^XUSEC supported by IA 10076
  1. ;
  1. Q
  1. PARAMETERS ; FROM^DIR^KEY^DATE^RDV^ALL^PDMP^SPN^EXC^NVAP^DFC^TIUDA^TYPE^HELP^DEBUG
  1. NEWPERSON(ORY,PARAMS) ; all parameters passed by reference
  1. S DT=$G(DT,$$DT^XLFDT),U="^",DUZ=$G(DUZ)
  1. N GBL,I,INF,J,MAX,P,PARAMETERS,PRM,TAG,XEC
  1. S PARAMETERS=$P($T(PARAMETERS),"; ",2) F I=1:1:$L(PARAMETERS,U) S PRM=$P(PARAMETERS,U,I) N @(PRM) D ; setup parameters
  1. . S (@(PRM),P(PRM))=$G(PARAMS(PRM)) ; set variables & parameters
  1. . S INF(I,PRM)=$S($D(PARAMS(PRM)):PARAMS(PRM),1:"") ; set for help
  1. I EXC S P("ORUCE")=$$GET^XPAR("SYS","OR CPRS USER CLASS EXCLUDE",1,"B") ; set OR CPRS USER CLASS EXCLUDE parameter
  1. S DIR=$S('DIR:1,1:DIR),MAX=44 ; direction & max results
  1. S GBL=$S((ALL!RDV):$NA(^VA(200,"B")),1:$NA(^VA(200,"AUSER"))) ; search global
  1. S TAG=$S(TYPE:"COS",DFC:"DFC",PDMP:"PDM",RDV:"RDV",ALL:"ALL",1:"USR") ; tag for criteria
  1. I TAG="COS" S P("DSC")=$$FIND1^DIC(8925.1,"","","DISCHARGE SUMMARY","","I $P(^(0),U,4)=""CL""","") ; discharge summary class
  1. F I=0:1 S J=$P($T(@TAG+I),";;",2,3) Q:J="" S XEC(I)=J ; execution criteria [evaluated reverse order]
  1. I HELP'=0 D HELP(.ORY,.INF,.XEC) Q ; REMOTE PROCEDURE information
  1. ; similiar provider name lookup receives IEN, returns all users that match LAST,FI [ignores max limit]
  1. ; example: CPRSPROVIDER,FIRSTNAME becomes CPRSPROVIDER,FH~
  1. I SPN N SPNQ D SPN(.FROM,.SPNQ) ; similar provider name lookup
  1. 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
  1. . N IEN S IEN=0 F Q:$S(SPN:0,1:I'<MAX) S IEN=$O(@GBL@(FROM,IEN)) Q:'IEN D
  1. . . N DIV,NODE0 S NODE0=$G(^VA(200,IEN,0)) Q:NODE0="" ; set zero node
  1. . . I PDMP D S P("DIV")=DIV ; ISAUTH^ORPDMP->$$DEA^XUSER - uses DUZ(2) of current user, not of evaluated user
  1. . . . S DIV=$$DIV4^XUSER(.DIV,IEN) I DIV=0 S DIV="" Q ; get division(s), quit if none
  1. . . . S DIV=$O(DIV(0))_U_$$GET1^DIQ(4,$O(DIV(0)),.01) ; set division
  1. . . . 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
  1. . . S P("IEN")=IEN,P("NODE0")=NODE0 ; set parameters
  1. . . I '$$EVALUATE(.XEC,.P) Q ; evaluate user
  1. . . 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
  1. . . S I=I+1,ORY(I)=$$DETAILS(NODE0,IEN,MORE,.DIV) ; user details
  1. Q
  1. EVALUATE(XEC,P) ;
  1. N CODE,RES,VAL S RES=1,VAL="" F S VAL=$O(P(VAL)) Q:VAL="" N @(VAL) S @(VAL)=P(VAL) ; set variables
  1. F VAL="COR","NVA" N @(VAL) S @(VAL)=$$CPRSTAB(IEN,$O(^ORD(101.13,"B",VAL,0)),DATE) ; set user CPRS TAB status
  1. 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
  1. S CODE="" F Q:'RES&('DEBUG) S CODE=$O(XEC(CODE),-1) Q:CODE="" X $P(XEC(CODE),";;") I $T D ; execute evaluation
  1. . W:DEBUG&RES=1 !!,"Verifying "_$P(NODE0,U)_"...",!!,IOUON_"Reason(s) for exclusion"_IOUOFF
  1. . S RES=0 W:DEBUG !,?2,@$P(XEC(CODE),";;",2) ; display exclusion description
  1. I PDMP S DUZ(2)=PDMPDIV ; revert DUZ(2)
  1. Q RES
  1. SPN(FROM,SPNQ) ; similar provider name lookup
  1. N NODE0 S NODE0=$G(^VA(200,FROM,0)) I NODE0="" S ORY(1)="-1^Invalid IEN" Q
  1. S FROM=$P(NODE0,U),FROM=$E(FROM,1,($L($P(FROM,","))+3)),SPNQ=FROM N FNM S FNM=$P(FROM,",",2)
  1. S $P(FROM,",",2)=$E(FNM,1,$L(FNM)-1)_$C($A(FNM,$L(FNM))-1)_"~" ; set FROM
  1. Q
  1. DETAILS(NODE0,IEN,MORE,DIV) ; get user information
  1. N DTL,ENTRY S DIV=$G(DIV),DTL="",ENTRY=IEN_"^"_$$NAMEFMT^XLFNAME($P(NODE0,U),"F","DcMPC")_"^",MORE=$G(MORE,0) ; IEN^user name
  1. S:$P(NODE0,U,9) DTL(1)=$$TITLE^XLFSTR($G(^DIC(3.1,$P(NODE0,U,9),0))) ; title
  1. I MORE D
  1. . 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
  1. . 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
  1. . S DIV=$$DIV4^XUSER(.DIV,IEN) Q:'DIV S DIV=$$GET1^DIQ(4,$O(DIV(0)),.01) ; get division
  1. . 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
  1. . S:DIV'="" DTL(3)=DIV ; division
  1. N NPI S NPI=+$$NPI^XUSNPI("Individual_ID",IEN) S:+NPI>0 DTL(4)="[NPI: "_NPI_"]" ; NPI
  1. 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
  1. Q ENTRY_DTL
  1. CPRSTAB(USER,TAB,DATE) ; return tab status
  1. ; 0 missing/expired, 1 assigned & current
  1. N RESULT S DATE=$S(+DATE:DATE,1:DT),RESULT=0
  1. Q:'$D(^VA(200,USER,"ORD","B",TAB)) RESULT ; quit, tab not assigned
  1. S TAB=$O(^VA(200,USER,"ORD","B",TAB,0)) Q:'+TAB RESULT ; get tab #
  1. S TAB=$G(^VA(200,USER,"ORD",TAB,0)) ; tab node=tab#^effective date^expiration date
  1. I DATE'<$P(TAB,U,2),DATE<$P(TAB,U,3)!($P(TAB,U,3)="") S RESULT=1
  1. Q RESULT
  1. DIC(DIC) ; basic lookup
  1. N DTOUT,DUOUT,X,Y S DIC=^DIC(DIC,0,"GL"),DIC(0)="AE" D ^DIC
  1. Q $S(+Y>0:Y,X=U:U,+$G(DTOUT):U,Y'>0:0,1:Y)
  1. DIR(DIR) ; basic reader
  1. N DIRUT,DTOUT,DUOUT,X,Y D ^DIR
  1. Q $S(+Y:Y,X=U:U,+$G(DTOUT):U,1:Y)
  1. HELP(ORY,INF,XEC) ; return detailed parameter & user evaluation information
  1. N GBL,I,IEN,J,NODE,X S IEN=$$FIND1^DIC(8994,,,"ORNEWPERS NEWPERSON"),X=0 Q:'IEN
  1. F NODE=2,3 S GBL=$S(NODE=2:$NA(^XWB(8994,IEN,2,1,1)),1:$NA(^XWB(8994,IEN,3))) D
  1. . S I=0 F S I=$O(@GBL@(I)) Q:'I S X=X+1,ORY(X)=@GBL@(I,0)
  1. S X=X+1,ORY(X)="",X=X+1,ORY(X)="Parameter Value"
  1. 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))
  1. 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"
  1. S X=X+1,ORY(X)="",X=X+1,ORY(X)="Current Evaluation Criteria"
  1. S I="" F S I=$O(XEC(I),-1) Q:I="" S X=X+1,ORY(X)=$P(XEC(I),";;")
  1. Q
  1. SETSTR(S,V,X,L) ; insert text(S) into variable(V) at position (X) with length of (L)
  1. Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
  1. USRCLEX(IEN,CLASS,ERR,DATE) ; NSR 20120101
  1. Q $$ISA^USRLM(IEN,CLASS,.ERR,DATE)
  1. ; criteria to screen users, evaluated in reverse order [bottom to top]
  1. ; code;;exclusion description (debug mode)
  1. 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"
  1. 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"
  1. 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"
  1. ;;I COR,VAL=-3;;"OR CPRS GUI CHART option missing"
  1. ;;S VAL=$$ACCESS^XQCHK(IEN,"OR CPRS GUI CHART") I COR,VAL=0;;"Not assigned OR CPRS GUI CHART option [any menu tree]"
  1. ;;I 'NVAP,NVA;;"Non-VA Provider excluded via parameter"
  1. 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")
  1. ;;I 'NVA,'COR;;"No CPRS TAB ACCESS assigned"
  1. ;;I +$P(NODE0,U,7);;"DISUSER status YES"
  1. 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))
  1. 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"
  1. ;;
  1. DEBUG ; evaluate a specific user, list below prompts user to determine RPC criteria entry point
  1. ;;ALL^YE^NO^Terminated or DISUSER allowed
  1. ;;RDV^YE^NO^Visitor only [for Remote Data View]
  1. ;;PDM^YE^NO^Must be authorized PDMP user
  1. ;;DFC^YE^NO^Screen for default co-signer selection
  1. ;;COS^YE^NO^Verify co-signature authorization for a document title
  1. ;;
  1. N DIC,DIR,DIV,I,J,NODE0,P,PRM,TAG,VAL,XEC,X,Y
  1. S DT=$G(DT,$$DT^XLFDT),U="^" D HOME^%ZIS,PREP^XGF W IOCUON
  1. S P=$P($T(PARAMETERS),"; ",2) F I=1:1:$L(P,U) S PRM=$P(P,U,I) N @(PRM) D ; setup parameters
  1. . S (@(PRM),P(PRM))=$G(PARAMS(PRM)) ; set variables & parameters
  1. S DIC=200,DIC("A")="Enter NEW PERSON to evaluate: ",VAL=+$$DIC(.DIC) G EXIT:'VAL ; ask for NEW PERSON
  1. S P("DEBUG")=1,P("IEN")=VAL,(NODE0,P("NODE0"))=^VA(200,+VAL,0)
  1. S DIV=$$DIV4^XUSER(.DIV,VAL) D:+DIV S P("DIV")=DIV ; check division
  1. . S DIV=$O(DIV(0))_U_$$GET1^DIQ(4,$O(DIV(0)),.01) ; set division
  1. . 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
  1. 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
  1. . N DIR S DIR(0)=$P(J,U,2),DIR("A")=$P(J,U,4),DIR("B")=$P(J,U,3)
  1. . 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
  1. G EXIT:VAL=U S TAG=$S(VAL="":"USR",1:VAL),VAL=1 ; set criteria entry point
  1. 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
  1. . S VAL=$$DIC(.DIC) Q:'VAL S P("TYPE")=+VAL ; ask for document definition
  1. . S P("DSC")=$$FIND1^DIC(8925.1,"","","DISCHARGE SUMMARY","","I $P(^(0),U,4)=""CL""","") ; set discharge summary class
  1. G EXIT:'VAL W !!,IOUON_"Optional Parameters"_IOUOFF
  1. 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
  1. 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
  1. I $S(TAG="ALL":0,TAG="RDV":0,TAG="PDM":0,1:1) D G EXIT:VAL=U
  1. . 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
  1. . 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
  1. I P("EXC") S P("ORUCE")=$$GET^XPAR("SYS","OR CPRS USER CLASS EXCLUDE",1,"B") ; set ASU class
  1. F I=0:1 S J=$P($T(@TAG+I),";;",2,5) Q:J="" S XEC(I)=J ; execution criteria [evaluated reverse order]
  1. S X=$$EVALUATE(.XEC,.P) W !!,$P(NODE0,U),$S(X:" would be selectable.",1:" would NOT be selectable.") ; display results
  1. W ! K DIR S DIR(0)="E" D ^DIR
  1. EXIT D CLEAN^XGF
  1. Q