Released DG*5.3*750 SEQ #716 Extracted from mail message **KIDS**:DG*5.3*750^ **INSTALL NAME** DG*5.3*750 "BLD",7935,0) DG*5.3*750^REGISTRATION^0^3090421^y "BLD",7935,1,0) ^^8^8^3090408^^ "BLD",7935,1,1,0) This patch corrects the following: "BLD",7935,1,2,0) Ensures that the Registration package will store long patient "BLD",7935,1,3,0) names properly. "BLD",7935,1,4,0) Catastrophic edit warning will not be displayed if only the "BLD",7935,1,5,0) pseudo Social Security Number is being changed. "BLD",7935,1,6,0) Catastrophic edit warning will be displayed if two or more edits to any "BLD",7935,1,7,0) potential CE field(patient name, ssn, dob, sex) have been done on the "BLD",7935,1,8,0) same day. "BLD",7935,4,0) ^9.64PA^^ "BLD",7935,6.3) 6 "BLD",7935,"INI") DG53P750 "BLD",7935,"INID") ^n^n "BLD",7935,"INIT") SEARCH^DG53P750 "BLD",7935,"KRN",0) ^9.67PA^779.2^20 "BLD",7935,"KRN",.4,0) .4 "BLD",7935,"KRN",.401,0) .401 "BLD",7935,"KRN",.402,0) .402 "BLD",7935,"KRN",.403,0) .403 "BLD",7935,"KRN",.5,0) .5 "BLD",7935,"KRN",.84,0) .84 "BLD",7935,"KRN",3.6,0) 3.6 "BLD",7935,"KRN",3.8,0) 3.8 "BLD",7935,"KRN",9.2,0) 9.2 "BLD",7935,"KRN",9.8,0) 9.8 "BLD",7935,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",7935,"KRN",9.8,"NM",1,0) DGRPAUD^^0^B6109099 "BLD",7935,"KRN",9.8,"NM",2,0) DGRP1^^0^B34628086 "BLD",7935,"KRN",9.8,"NM",3,0) DGRPECE^^0^B73130741 "BLD",7935,"KRN",9.8,"NM","B","DGRP1",2) "BLD",7935,"KRN",9.8,"NM","B","DGRPAUD",1) "BLD",7935,"KRN",9.8,"NM","B","DGRPECE",3) "BLD",7935,"KRN",19,0) 19 "BLD",7935,"KRN",19.1,0) 19.1 "BLD",7935,"KRN",101,0) 101 "BLD",7935,"KRN",409.61,0) 409.61 "BLD",7935,"KRN",771,0) 771 "BLD",7935,"KRN",779.2,0) 779.2 "BLD",7935,"KRN",870,0) 870 "BLD",7935,"KRN",8989.51,0) 8989.51 "BLD",7935,"KRN",8989.52,0) 8989.52 "BLD",7935,"KRN",8994,0) 8994 "BLD",7935,"KRN","B",.4,.4) "BLD",7935,"KRN","B",.401,.401) "BLD",7935,"KRN","B",.402,.402) "BLD",7935,"KRN","B",.403,.403) "BLD",7935,"KRN","B",.5,.5) "BLD",7935,"KRN","B",.84,.84) "BLD",7935,"KRN","B",3.6,3.6) "BLD",7935,"KRN","B",3.8,3.8) "BLD",7935,"KRN","B",9.2,9.2) "BLD",7935,"KRN","B",9.8,9.8) "BLD",7935,"KRN","B",19,19) "BLD",7935,"KRN","B",19.1,19.1) "BLD",7935,"KRN","B",101,101) "BLD",7935,"KRN","B",409.61,409.61) "BLD",7935,"KRN","B",771,771) "BLD",7935,"KRN","B",779.2,779.2) "BLD",7935,"KRN","B",870,870) "BLD",7935,"KRN","B",8989.51,8989.51) "BLD",7935,"KRN","B",8989.52,8989.52) "BLD",7935,"KRN","B",8994,8994) "BLD",7935,"QDEF") ^^^^^^^^^^YES "BLD",7935,"QUES",0) ^9.62^^ "BLD",7935,"REQB",0) ^9.611^1^1 "BLD",7935,"REQB",1,0) DG*5.3*688^1 "BLD",7935,"REQB","B","DG*5.3*688",1) "INI") DG53P750 "INIT") SEARCH^DG53P750 "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813^2930918 "PKG",5,22,1,"PAH",1,0) 750^3090421 "PKG",5,22,1,"PAH",1,1,0) ^^8^8^3090421 "PKG",5,22,1,"PAH",1,1,1,0) This patch corrects the following: "PKG",5,22,1,"PAH",1,1,2,0) Ensures that the Registration package will store long patient "PKG",5,22,1,"PAH",1,1,3,0) names properly. "PKG",5,22,1,"PAH",1,1,4,0) Catastrophic edit warning will not be displayed if only the "PKG",5,22,1,"PAH",1,1,5,0) pseudo Social Security Number is being changed. "PKG",5,22,1,"PAH",1,1,6,0) Catastrophic edit warning will be displayed if two or more edits to any "PKG",5,22,1,"PAH",1,1,7,0) potential CE field(patient name, ssn, dob, sex) have been done on the "PKG",5,22,1,"PAH",1,1,8,0) same day. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 4 "RTN","DG53P750") 0^^B18640459^n/a "RTN","DG53P750",1,0) DG53P750 ;BAY/JT - Patient full name > 30 characters ; 9/16/03 4:56pm "RTN","DG53P750",2,0) ;;5.3;Registration;**750**;Aug 13, 1993;Build 6 "RTN","DG53P750",3,0) ; update patient name .01 in file #2 "RTN","DG53P750",4,0) ; "RTN","DG53P750",5,0) ENV ; do environment check "RTN","DG53P750",6,0) S XPDABORT="" "RTN","DG53P750",7,0) D PROGCHK(.XPDABORT) "RTN","DG53P750",8,0) I XPDABORT="" K XPDABORT "RTN","DG53P750",9,0) Q "RTN","DG53P750",10,0) PROGCHK(XPDABORT) ; checks for necessary programmer variables "RTN","DG53P750",11,0) I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D "RTN","DG53P750",12,0) .D MES^XPDUTL("Your programming variables are not set up properly.") "RTN","DG53P750",13,0) .D MES^XPDUTL("Installation aborted.") "RTN","DG53P750",14,0) .S XPDABORT=2 "RTN","DG53P750",15,0) Q "RTN","DG53P750",16,0) ; "RTN","DG53P750",17,0) SEARCH N DGIEN,DGTOT,DGFULLNM,DGLINK,DGZERO,DGONE,DGOTHERS,X1,X2 "RTN","DG53P750",18,0) N DG20NAME,XUNOTRIG,FDANAME,FDAIEN,DIERR "RTN","DG53P750",19,0) K ^XTMP("DG53P750") "RTN","DG53P750",20,0) S X1=DT,X2=90 D C^%DTC "RTN","DG53P750",21,0) S ^XTMP("DG53P750",0)=X_"^"_DT_"^Patient full name > 30 characters" "RTN","DG53P750",22,0) S (DGIEN,DGTOT,DGOTHERS)=0 "RTN","DG53P750",23,0) D BMES^XPDUTL("...Reading thru entire Patient File...") "RTN","DG53P750",24,0) F S DGIEN=$O(^DPT(DGIEN)) Q:'DGIEN D "RTN","DG53P750",25,0) .S DGTOT=DGTOT+1 "RTN","DG53P750",26,0) .S DGFULLNM=$P($G(^DPT(DGIEN,0)),U) "RTN","DG53P750",27,0) .; skip merge records "RTN","DG53P750",28,0) .Q:DGFULLNM["MERGING INTO" "RTN","DG53P750",29,0) .Q:$D(^DPT(DGIEN,-9)) "RTN","DG53P750",30,0) .Q:DGFULLNM="" "RTN","DG53P750",31,0) .Q:$L(DGFULLNM)<31 "RTN","DG53P750",32,0) .; skip if word "error" in family name "RTN","DG53P750",33,0) .Q:$P(DGFULLNM,",",1)["ERROR" "RTN","DG53P750",34,0) .S DGLINK=+$P($G(^DPT(DGIEN,"NAME")),U) "RTN","DG53P750",35,0) .I 'DGLINK Q "RTN","DG53P750",36,0) .S DGZERO=$G(^VA(20,DGLINK,0)) "RTN","DG53P750",37,0) .I DGZERO="" Q "RTN","DG53P750",38,0) .; make sure the patient name component record points back to the patient file record "RTN","DG53P750",39,0) .I $P(DGZERO,U)'=2!($P(DGZERO,U,2)'=".01")!(+$P(DGZERO,U,3)'=DGIEN) Q "RTN","DG53P750",40,0) .S DGONE=$G(^VA(20,DGLINK,1)) "RTN","DG53P750",41,0) .I DGONE="" Q "RTN","DG53P750",42,0) .; get the name components "RTN","DG53P750",43,0) .S DG20NAME=$P(DGONE,U)_"," "RTN","DG53P750",44,0) .I $P(DGONE,U,2)'="" S DG20NAME=DG20NAME_$P(DGONE,U,2) "RTN","DG53P750",45,0) .I $P(DGONE,U,3)'="" S DG20NAME=DG20NAME_" "_$P(DGONE,U,3) "RTN","DG53P750",46,0) .I $P(DGONE,U,5)'="" S DG20NAME=DG20NAME_" "_$P(DGONE,U,5) "RTN","DG53P750",47,0) .; reformat it so it's no more than 30 characters "RTN","DG53P750",48,0) .S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30") "RTN","DG53P750",49,0) .S FDAIEN=DGIEN_"," "RTN","DG53P750",50,0) .S FDANAME(2,FDAIEN,.01)=DG20NAME "RTN","DG53P750",51,0) .; set flag so patient name component record will not be updated "RTN","DG53P750",52,0) .S XUNOTRIG=1 "RTN","DG53P750",53,0) .; update the .01 field "RTN","DG53P750",54,0) .D FILE^DIE("","FDANAME","DIERR") "RTN","DG53P750",55,0) .; store global entry so report can be prepared from it "RTN","DG53P750",56,0) .S ^XTMP("DG53P750",DGIEN,DGLINK)=DGFULLNM_"///"_DG20NAME "RTN","DG53P750",57,0) .S DGOTHERS=DGOTHERS+1 "RTN","DG53P750",58,0) ; "RTN","DG53P750",59,0) D MES^XPDUTL("Total # of Patient File records read: "_DGTOT) "RTN","DG53P750",60,0) D MES^XPDUTL("Total # of corrected patients: "_DGOTHERS) "RTN","DG53P750",61,0) Q "RTN","DG53P750",62,0) ; "RTN","DG53P750",63,0) PRTRPT ; "RTN","DG53P750",64,0) I $$DEVICE() D PRINT "RTN","DG53P750",65,0) Q "RTN","DG53P750",66,0) DEVICE() ; choose device and whether to queue. "RTN","DG53P750",67,0) N OK,IOP,POP,%ZIS,DGX "RTN","DG53P750",68,0) S OK=1 "RTN","DG53P750",69,0) S %ZIS="MQ" "RTN","DG53P750",70,0) D ^%ZIS "RTN","DG53P750",71,0) S:POP OK=0 "RTN","DG53P750",72,0) I OK,$D(IO("Q")) D "RTN","DG53P750",73,0) .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP "RTN","DG53P750",74,0) .S ZTRTN="PRINT^DG53P750" "RTN","DG53P750",75,0) .S ZTDESC="Print of XTMP global for DG53P750." "RTN","DG53P750",76,0) .F DGX=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) "RTN","DG53P750",77,0) .W !,$S($D(ZTSK):"Request "_ZTSK_" queued!",1:"Request Cancelled!"),! "RTN","DG53P750",78,0) .D HOME^%ZIS "RTN","DG53P750",79,0) .S OK=0 "RTN","DG53P750",80,0) Q OK "RTN","DG53P750",81,0) ; "RTN","DG53P750",82,0) PRINT ; "RTN","DG53P750",83,0) U IO "RTN","DG53P750",84,0) N DGIEN,DGLINK,DGERR,DGQUIT,DGPG,DGDDT "RTN","DG53P750",85,0) S (DGQUIT,DGPG)=0 "RTN","DG53P750",86,0) S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D") "RTN","DG53P750",87,0) D HEAD "RTN","DG53P750",88,0) S DGIEN=0,DGIEN=$O(^XTMP("DG53P750",DGIEN)) "RTN","DG53P750",89,0) I DGIEN="" D Q "RTN","DG53P750",90,0) .W !!!,?20,"*** No records to report ***" "RTN","DG53P750",91,0) ; "RTN","DG53P750",92,0) S DGIEN=0 "RTN","DG53P750",93,0) F S DGIEN=$O(^XTMP("DG53P750",DGIEN)) Q:'DGIEN D Q:DGQUIT "RTN","DG53P750",94,0) .S DGLINK=0 "RTN","DG53P750",95,0) .F S DGLINK=$O(^XTMP("DG53P750",DGIEN,DGLINK)) Q:'DGLINK D "RTN","DG53P750",96,0) ..I $Y>(IOSL-4) D HEAD "RTN","DG53P750",97,0) ..W DGIEN,?11,DGLINK,?25,^XTMP("DG53P750",DGIEN,DGLINK),! "RTN","DG53P750",98,0) ; "RTN","DG53P750",99,0) I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q "RTN","DG53P750",100,0) I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 "RTN","DG53P750",101,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","DG53P750",102,0) Q "RTN","DG53P750",103,0) HEAD ; "RTN","DG53P750",104,0) I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q "RTN","DG53P750",105,0) I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 "RTN","DG53P750",106,0) Q:DGQUIT "RTN","DG53P750",107,0) S DGPG=$G(DGPG)+1 "RTN","DG53P750",108,0) W @IOF,!,DGDDT,?15,"DG*5.3*750 List of patients with long names",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",132)="" W X,! "RTN","DG53P750",109,0) W !,"File 2 IEN",?11,"File 20 IEN",?25,"Patient Name Before///Patient Name After",! "RTN","DG53P750",110,0) S $P(X,"-",132)="" W X,! "RTN","DG53P750",111,0) Q "RTN","DGRP1") 0^2^B34628086^B34627316 "RTN","DGRP1",1,0) DGRP1 ;ALB/MRL,ERC,BAJ - DEMOGRAPHIC DATA ; 8/15/08 11:30am "RTN","DGRP1",2,0) ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,688,750**;Aug 13, 1993;Build 6 "RTN","DGRP1",3,0) ; "RTN","DGRP1",4,0) EN ; "RTN","DGRP1",5,0) S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.122,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP1",6,0) I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRP1",7,0) ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRP1",8,0) ;Retrieve SSN Verification status DG*5.3*688 BAJ 11/22/2005 "RTN","DGRP1",9,0) N SSNV D GETSTAT(.SSNV) "RTN","DGRP1",10,0) W ! S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV "RTN","DGRP1",11,0) ;Display SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005 "RTN","DGRP1",12,0) W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV W SSNV "RTN","DGRP1",13,0) W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y "RTN","DGRP1",14,0) ;add Pseuso SSN Reason - DG*5.3*653, ERC "RTN","DGRP1",15,0) I $P(DGRP(0),U,9)["P" D "RTN","DGRP1",16,0) . N DGSPACE "RTN","DGRP1",17,0) . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen "RTN","DGRP1",18,0) . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: " "RTN","DGRP1",19,0) . I $P(DGRP(0),U,9)["P" D "RTN","DGRP1",20,0) . . N DGREAS D SSNREAS(.DGREAS) "RTN","DGRP1",21,0) . . Q:$G(DGREAS)']"" "RTN","DGRP1",22,0) . . W DGREAS "RTN","DGRP1",23,0) D GETNCAL ;Display name component, sex, and alias information "RTN","DGRP1",24,0) S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU "RTN","DGRP1",25,0) S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17 "RTN","DGRP1",26,0) D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: " "RTN","DGRP1",27,0) W !?9 "RTN","DGRP1",28,0) S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS") "RTN","DGRP1",29,0) ; loop through DGA array beginning with DGA(2) and print data at ?9 (odds) and ?48 (evens) "RTN","DGRP1",30,0) S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?9 W:'(I#2) ?48 W DGA(I) "RTN","DGRP1",31,0) D COUNTY(.DGRP) ; print County if applicable "RTN","DGRP1",32,0) W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) "RTN","DGRP1",33,0) S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU) "RTN","DGRP1",34,0) W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X "RTN","DGRP1",35,0) W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16)) "RTN","DGRP1",36,0) ; "RTN","DGRP1",37,0) ; *** Additional displays added for Pre-Registration "RTN","DGRP1",38,0) I $G(DGPRFLG)=1 D "RTN","DGRP1",39,0) . W ! "RTN","DGRP1",40,0) . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1 "RTN","DGRP1",41,0) . I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1 I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2) "RTN","DGRP1",42,0) . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D") "RTN","DGRP1",43,0) . I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1 S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2) "RTN","DGRP1",44,0) . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D") "RTN","DGRP1",45,0) . I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1 S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2) "RTN","DGRP1",46,0) . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D") "RTN","DGRP1",47,0) . I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1 S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2) "RTN","DGRP1",48,0) . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D") "RTN","DGRP1",49,0) . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration "RTN","DGRP1",50,0) . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI D "RTN","DGRP1",51,0) .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2) "RTN","DGRP1",52,0) .. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D") "RTN","DGRP1",53,0) ; "RTN","DGRP1",54,0) G ^DGRPP "RTN","DGRP1",55,0) ; "RTN","DGRP1",56,0) GETNCAL ;Get name component values "RTN","DGRP1",57,0) N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW "RTN","DGRP1",58,0) S DGNC="Family^Given^Middle^Prefix^Suffix^Degree" "RTN","DGRP1",59,0) S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," "RTN","DGRP1",60,0) I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") "RTN","DGRP1",61,0) ;Get alias values "RTN","DGRP1",62,0) S DGA=0 F DGI=1:1:5 D Q:'$D(DGALIAS(DGI)) "RTN","DGRP1",63,0) A2 .S DGA=$O(^DPT(DFN,.01,DGA)) "RTN","DGRP1",64,0) .I 'DGA D:DGI=1 Q "RTN","DGRP1",65,0) ..S DGALIAS(DGI)="< No alias entries on file >" Q "RTN","DGRP1",66,0) .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q "RTN","DGRP1",67,0) .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2 "RTN","DGRP1",68,0) .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2) "RTN","DGRP1",69,0) .I $L(DGX) D "RTN","DGRP1",70,0) ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9) "RTN","DGRP1",71,0) ..; BAJ DG*5.2*700 retrofit 06/22/06 "RTN","DGRP1",72,0) ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19) "RTN","DGRP1",73,0) ..S $E(DGALIAS(DGI),20)=DGX Q "RTN","DGRP1",74,0) .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32) "RTN","DGRP1",75,0) .Q "RTN","DGRP1",76,0) ;Display name component, sex, multiple birth indicator and alias data "RTN","DGRP1",77,0) F DGI=1:1:6 D "RTN","DGRP1",78,0) .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:28,1:27)) "RTN","DGRP1",79,0) .; BAJ DG*5.3*700 retrofit 06/22/06 "RTN","DGRP1",80,0) .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV "RTN","DGRP1",81,0) .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV "RTN","DGRP1",82,0) .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: " "RTN","DGRP1",83,0) .I DGI>1 W ?47,$G(DGALIAS(DGI-1)) "RTN","DGRP1",84,0) .Q "RTN","DGRP1",85,0) Q "RTN","DGRP1",86,0) GETSTAT(SSNV) ;get SSN VERIFIED STATUS DG*5.3*688 BAJ 11/22/2005 "RTN","DGRP1",87,0) N T "RTN","DGRP1",88,0) S T=$P($G(^DPT(DFN,"SSN")),"^",2) "RTN","DGRP1",89,0) S SSNV=$S(T=2:"INVALID",T=4:"VERIFIED",1:"") "RTN","DGRP1",90,0) Q "RTN","DGRP1",91,0) ; "RTN","DGRP1",92,0) SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC "RTN","DGRP1",93,0) S DGREAS=$P(DGRP("SSN"),U) "RTN","DGRP1",94,0) I $G(DGREAS)']"" Q "RTN","DGRP1",95,0) S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >") "RTN","DGRP1",96,0) Q "RTN","DGRP1",97,0) COUNTY(DGRP) ;retrieve and print County info if a US address "RTN","DGRP1",98,0) N DGCC,CNODE,FNODE,FPCE,FILE,IEN,CNTRY,PLINE "RTN","DGRP1",99,0) ; data location of Permanent Address County info "RTN","DGRP1",100,0) S FNODE=.11,FPCE=10,DGCC="" "RTN","DGRP1",101,0) ; only print county info if it's a US address "RTN","DGRP1",102,0) S IEN=$P(DGRP(FNODE),U,FPCE) I '$$FORIEN^DGADDUTL(IEN) D "RTN","DGRP1",103,0) . S DGCC=$S($D(^DIC(5,+$P(DGRP(FNODE),U,5),1,+$P(DGRP(FNODE),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) "RTN","DGRP1",104,0) S PLINE=$S(DGCC]"":"County: "_DGCC,1:"") "RTN","DGRP1",105,0) W !?3,PLINE "RTN","DGRP1",106,0) S DGCC="" "RTN","DGRP1",107,0) ; data location of Temporary address County info "RTN","DGRP1",108,0) S CNODE=.121,FNODE=.122,FPCE=3 "RTN","DGRP1",109,0) ; only print county info if it's a US address "RTN","DGRP1",110,0) S IEN=$P(DGRP(FNODE),U,FPCE) I '$$FORIEN^DGADDUTL(IEN) D "RTN","DGRP1",111,0) . S DGCC=$S($P(DGRP(CNODE),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(CNODE),U,5),1,+$P(DGRP(CNODE),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) "RTN","DGRP1",112,0) S PLINE=$S(DGCC]"":"County: "_DGCC,1:"") "RTN","DGRP1",113,0) W ?43,PLINE "RTN","DGRP1",114,0) Q "RTN","DGRP1",115,0) ; "RTN","DGRPAUD") 0^1^B6109099^n/a "RTN","DGRPAUD",1,0) DGRPAUD ;BP/MJB - REGISTRATION CATASTROPHIC EDITS ;Compiled May 21, 2008 14:52:59 "RTN","DGRPAUD",2,0) ;;5.3;Registration;**750**;Aug 13, 1993;Build 6 "RTN","DGRPAUD",3,0) ;This routine will be called by DGRPECE if a change is made to patient name, ssn, dob, and sex. "RTN","DGRPAUD",4,0) ;It will will get patient information from the audit file for comparisons. "RTN","DGRPAUD",5,0) ;DGIEN-Audit file IEN(S) for patient "RTN","DGRPAUD",6,0) ;DGAUDZRO-zero node of the audit file "RTN","DGRPAUD",7,0) ;DGDT-date in audit file "RTN","DGRPAUD",8,0) ;DGFLDNMR=field number of change "RTN","DGRPAUD",9,0) ;DGOPTION-option used to make the update "RTN","DGRPAUD",10,0) ;DGCHG=check to verify if a change was made "RTN","DGRPAUD",11,0) ; "RTN","DGRPAUD",12,0) DGAUD(DFN,DGCNT) ;SET AUDITS FOR PATIENT "RTN","DGRPAUD",13,0) N DGI,DGIEN,DGAUDIEN,DGAUDZRO,DGFLDNBR,DGOPTION,DGPTIEN,DGDT,DGCHG,DGTM,DGTODAY "RTN","DGRPAUD",14,0) K ^TMP("DGRPAUD") "RTN","DGRPAUD",15,0) S DGI=0,DGAUDZRO=0,U="^" "RTN","DGRPAUD",16,0) S DGTODAY=$P($$NOW^XLFDT(),".") "RTN","DGRPAUD",17,0) F S DGI=$O(^DIA(2,"B",DFN,DGI)) Q:'DGI D ;Get all audit IENS for patient. "RTN","DGRPAUD",18,0) .S DGIEN(DGI)=DGI "RTN","DGRPAUD",19,0) .S DGAUDZRO=$G(^DIA(2,DGIEN(DGI),0)) ;get zero node for all audits "RTN","DGRPAUD",20,0) .I 'DGAUDZRO Q "RTN","DGRPAUD",21,0) .S DGDT=$P(DGAUDZRO,"^",2),DGTM=$P(DGDT,".",1) "RTN","DGRPAUD",22,0) .I DGTODAY'=DGTM Q ;only get todays audits "RTN","DGRPAUD",23,0) .S DGFLDNBR=$P(DGAUDZRO,"^",3) "RTN","DGRPAUD",24,0) .;get only NAME(.01),SEX(.02),DOB(.03),SSN(.09) for catastrophic edit checks "RTN","DGRPAUD",25,0) .I DGFLDNBR'=".01"&(DGFLDNBR'=".02")&(DGFLDNBR'=".03")&(DGFLDNBR'=".09") Q "RTN","DGRPAUD",26,0) .S DGOPTION=$P($G(^DIA(2,DGIEN(DGI),4.1)),U) "RTN","DGRPAUD",27,0) .I 'DGOPTION Q "RTN","DGRPAUD",28,0) .S DGCHG=$G(^DIA(2,DGIEN(DGI),2)) ;Check to see if change was made "RTN","DGRPAUD",29,0) .I '$D(DGCHG)!(DGCHG="") Q "RTN","DGRPAUD",30,0) .S DGPTIEN=$P(DGAUDZRO,U) "RTN","DGRPAUD",31,0) .;set data into a temp global to be used by DGRPECE for changes "RTN","DGRPAUD",32,0) .;this temp global will show changes that are currently in the audit file for this patient "RTN","DGRPAUD",33,0) .;piece 1 - date and time of change "RTN","DGRPAUD",34,0) .;piece 2 - changed field "RTN","DGRPAUD",35,0) .;piece 3 - option used to change "RTN","DGRPAUD",36,0) .;piece 4 - previous field value "RTN","DGRPAUD",37,0) .;piece 5 - new field value "RTN","DGRPAUD",38,0) .S ^TMP("DGRPAUD",$J,DFN,DGIEN(DGI))=$P(DGAUDZRO,U,2)_"^"_DGFLDNBR_"^"_DGOPTION_"^"_$G(^DIA(2,DGIEN(DGI),2))_"^"_$G(^DIA(2,DGIEN(DGI),3))_"^"_$P(DGAUDZRO,U,5) "RTN","DGRPAUD",39,0) ; "RTN","DGRPAUD",40,0) N DGAUDIEN "RTN","DGRPAUD",41,0) S DGAUDIEN=0 "RTN","DGRPAUD",42,0) F S DGAUDIEN=$O(^TMP("DGRPAUD",$J,DFN,DGAUDIEN)) Q:'DGAUDIEN D "RTN","DGRPAUD",43,0) .S DGCNT=DGCNT+1 "RTN","DGRPAUD",44,0) Q "RTN","DGRPECE") 0^3^B73130741^B66239213 "RTN","DGRPECE",1,0) DGRPECE ;ALB/MRY,ERC,BAJ - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 3:27pm "RTN","DGRPECE",2,0) ;;5.3;Registration;**638,682,700,720,653,688,750**;Aug 13, 1993;Build 6 "RTN","DGRPECE",3,0) ; "RTN","DGRPECE",4,0) CEDITS(DFN) ;catastrophic edits - buffer values, save after check "RTN","DGRPECE",5,0) ;Input; "RTN","DGRPECE",6,0) ; DFN := patient ien "RTN","DGRPECE",7,0) ;Catastrophic edits will prompt for name, ssn, dob, and sex. Placing "RTN","DGRPECE",8,0) ;responses into a buffer space. User will be alerted on catastrophic "RTN","DGRPECE",9,0) ;edits on the following conditions: "RTN","DGRPECE",10,0) ; 1. Two or more catastrophic edits will generate a warning message. "RTN","DGRPECE",11,0) ; 2. Acceptance of two or more catastrophic edits will generate an alert "RTN","DGRPECE",12,0) ; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key. "RTN","DGRPECE",13,0) ; 3. Acceptance of <2 catastrophic edits will process normally. "RTN","DGRPECE",14,0) ; "RTN","DGRPECE",15,0) ; Arrays: BEFORE - Holds patient values before the edit process "RTN","DGRPECE",16,0) ; (before snapshot). "RTN","DGRPECE",17,0) ; BUFFER - initialized with BEFORE array, holds edited changes "RTN","DGRPECE",18,0) ; (after snapshot). "RTN","DGRPECE",19,0) ; SAVE - holds only edited changes for filing into file #2. "RTN","DGRPECE",20,0) ; "RTN","DGRPECE",21,0) N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN,XUNOTRIG "RTN","DGRPECE",22,0) D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values "RTN","DGRPECE",23,0) ;buffer - get name "RTN","DGRPECE",24,0) K DG20NAME "RTN","DGRPECE",25,0) S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME) "RTN","DGRPECE",26,0) I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME") "RTN","DGRPECE",27,0) I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY") "RTN","DGRPECE",28,0) I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN") "RTN","DGRPECE",29,0) I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE") "RTN","DGRPECE",30,0) I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX") "RTN","DGRPECE",31,0) ; the formal name is last name, first name, middle name and suffix "RTN","DGRPECE",32,0) ; the prefix and degree are only stored in file 20 "RTN","DGRPECE",33,0) I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX") "RTN","DGRPECE",34,0) I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE") "RTN","DGRPECE",35,0) K DG20NAME "RTN","DGRPECE",36,0) ;DG*5.3*688 BAJ if SSN is verified, do not allow edits "RTN","DGRPECE",37,0) I BEFORE("SSNV")="VERIFIED" D G DOB "RTN","DGRPECE",38,0) . S BUFFER("SSN")=BEFORE("SSN") "RTN","DGRPECE",39,0) . W !,"SSN: "_BUFFER("SSN") "RTN","DGRPECE",40,0) . W !,"SOCIAL SECURITY NUMBER "_BUFFER("SSN")_" has been verified by SSA --NO EDITING" "RTN","DGRPECE",41,0) ; "RTN","DGRPECE",42,0) ;buffer - get ssn "RTN","DGRPECE",43,0) S DIR(0)="2,.09^^" "RTN","DGRPECE",44,0) S DA=DFN D ^DIR "RTN","DGRPECE",45,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",46,0) S BUFFER("SSN")=Y "RTN","DGRPECE",47,0) ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC "RTN","DGRPECE",48,0) I $G(BUFFER("SSN"))["P" D I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",49,0) REAS . ; "RTN","DGRPECE",50,0) . N DGREA,DGQSSN,DIR "RTN","DGRPECE",51,0) . S DGQSSN=0 "RTN","DGRPECE",52,0) . S DGREA=$P($G(^DPT(DFN,"SSN")),U) "RTN","DGRPECE",53,0) . S DIR(0)="2,.0906^^" "RTN","DGRPECE",54,0) . S DA=DFN "RTN","DGRPECE",55,0) . D ^DIR "RTN","DGRPECE",56,0) . I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D "RTN","DGRPECE",57,0) . . W !?10,"PSSN Reason Required if SSN is a Pseudo." "RTN","DGRPECE",58,0) . . I $G(BEFORE("SSN"))["P" G REAS "RTN","DGRPECE",59,0) . . I $G(BEFORE("SSN"))']"" G REAS "RTN","DGRPECE",60,0) . . S DIR(0)="YA",DIR("A")=" Delete Pseudo SSN?: ",DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason.",DIR("B")="YES" "RTN","DGRPECE",61,0) . . D ^DIR "RTN","DGRPECE",62,0) . . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q "RTN","DGRPECE",63,0) . . G REAS "RTN","DGRPECE",64,0) . I DGQSSN=1 Q "RTN","DGRPECE",65,0) . S BUFFER("SSNREAS")=Y "RTN","DGRPECE",66,0) . I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q "RTN","DGRPECE",67,0) DOB ;buffer - get dob "RTN","DGRPECE",68,0) S DIR(0)="2,.03^^" "RTN","DGRPECE",69,0) S DA=DFN D ^DIR "RTN","DGRPECE",70,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",71,0) S BUFFER("DOB")=Y "RTN","DGRPECE",72,0) SEX ;buffer - get sex "RTN","DGRPECE",73,0) S DIR(0)="2,.02^^" "RTN","DGRPECE",74,0) S DA=DFN D ^DIR "RTN","DGRPECE",75,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",76,0) S BUFFER("SEX")=Y "RTN","DGRPECE",77,0) MBI ; buffer - get MBI (multiple birth indicator) "RTN","DGRPECE",78,0) S DIR(0)="2,994^^" "RTN","DGRPECE",79,0) S DA=DFN D ^DIR "RTN","DGRPECE",80,0) S BUFFER("MBI")=Y "RTN","DGRPECE",81,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",82,0) CECHECK ;do catastrophic edit checks, alert, and save "RTN","DGRPECE",83,0) N DGCNT,DGCEFLG "RTN","DGRPECE",84,0) ;Compare before/buffer arrays, putting edits into save array. "RTN","DGRPECE",85,0) S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE) "RTN","DGRPECE",86,0) ; DGCNT: 0 = no changes "RTN","DGRPECE",87,0) ; 1 = only one edit change, ok to save w/o CE message "RTN","DGRPECE",88,0) ; >1 = more then 1 edit, give CE message "RTN","DGRPECE",89,0) I DGCNT>1 D ;give CE message "RTN","DGRPECE",90,0) . S DGCEFLG=$$WARNING() "RTN","DGRPECE",91,0) . ; DGCEFLG: 0 = exit without saving changes "RTN","DGRPECE",92,0) . ; 1 = send alert and save "RTN","DGRPECE",93,0) . I DGCEFLG=0 S DGCNT=0 "RTN","DGRPECE",94,0) I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT "RTN","DGRPECE",95,0) Q "RTN","DGRPECE",96,0) ; "RTN","DGRPECE",97,0) SAVE(DFN) ;store accepted/edited values into patient file "RTN","DGRPECE",98,0) N FDATA,DIERR "RTN","DGRPECE",99,0) I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME") "RTN","DGRPECE",100,0) I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB") "RTN","DGRPECE",101,0) I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX") "RTN","DGRPECE",102,0) I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN") "RTN","DGRPECE",103,0) I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS") "RTN","DGRPECE",104,0) I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI") "RTN","DGRPECE",105,0) D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",106,0) K FDATA,DIERR "RTN","DGRPECE",107,0) I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") "RTN","DGRPECE",108,0) I $D(SAVE("NAME")) D "RTN","DGRPECE",109,0) .S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY") "RTN","DGRPECE",110,0) .S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN") "RTN","DGRPECE",111,0) .S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE") "RTN","DGRPECE",112,0) .S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX") "RTN","DGRPECE",113,0) .S XUNOTRIG=1 "RTN","DGRPECE",114,0) .D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",115,0) .K FDATA,DIERR "RTN","DGRPECE",116,0) I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX") "RTN","DGRPECE",117,0) I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE") "RTN","DGRPECE",118,0) I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX") "RTN","DGRPECE",119,0) I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE") "RTN","DGRPECE",120,0) D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",121,0) K FDATA,DIERR "RTN","DGRPECE",122,0) Q "RTN","DGRPECE",123,0) ; "RTN","DGRPECE",124,0) BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree "RTN","DGRPECE",125,0) N DG20 "RTN","DGRPECE",126,0) S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME") "RTN","DGRPECE",127,0) S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN") "RTN","DGRPECE",128,0) ;Get SSN Verification flag DG*5.3*688 BAJ 11/22/2005 "RTN","DGRPECE",129,0) S BEF("SSNV")=$$GET1^DIQ(2,+IEN_",",.0907),BUF("SSNV")=BEF("SSNV") "RTN","DGRPECE",130,0) S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS") "RTN","DGRPECE",131,0) S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB") "RTN","DGRPECE",132,0) S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX") "RTN","DGRPECE",133,0) S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI") "RTN","DGRPECE",134,0) D GETS^DIQ(2,+IEN_",",1.01,"I","DG20") "RTN","DGRPECE",135,0) S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")="" "RTN","DGRPECE",136,0) S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")="" "RTN","DGRPECE",137,0) S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")="" "RTN","DGRPECE",138,0) S DG20IEN=DG20(2,+IEN_",",1.01,"I") "RTN","DGRPECE",139,0) I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D "RTN","DGRPECE",140,0) . S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY") "RTN","DGRPECE",141,0) . S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN") "RTN","DGRPECE",142,0) . S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE") "RTN","DGRPECE",143,0) . S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX") "RTN","DGRPECE",144,0) . S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX") "RTN","DGRPECE",145,0) . S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE") "RTN","DGRPECE",146,0) ;add some demographic information (before snapshot) "RTN","DGRPECE",147,0) S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17) "RTN","DGRPECE",148,0) S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15) "RTN","DGRPECE",149,0) S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I") "RTN","DGRPECE",150,0) Q "RTN","DGRPECE",151,0) ; "RTN","DGRPECE",152,0) AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks "RTN","DGRPECE",153,0) N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0 "RTN","DGRPECE",154,0) I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D "RTN","DGRPECE",155,0) . S DG20CNT=DG20CNT+1 "RTN","DGRPECE",156,0) . S SAV("NAME")=BUF("NAME") "RTN","DGRPECE",157,0) I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D "RTN","DGRPECE",158,0) . S DG20CNT=DG20CNT+1 "RTN","DGRPECE",159,0) . S SAV("NAME")=BUF("NAME") "RTN","DGRPECE",160,0) I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D "RTN","DGRPECE",161,0) . S SAV("NAME")=BUF("NAME") ; minor change doesn't count "RTN","DGRPECE",162,0) I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D "RTN","DGRPECE",163,0) . S SAV("NAME")=BUF("NAME") ; minor change doesn't count "RTN","DGRPECE",164,0) I DG20CNT>0 S DGCNT=1 "RTN","DGRPECE",165,0) I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D "RTN","DGRPECE",166,0) . S SAV("PREFIX")=BUF("PREFIX") "RTN","DGRPECE",167,0) I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D "RTN","DGRPECE",168,0) . S SAV("DEGREE")=BUF("DEGREE") "RTN","DGRPECE",169,0) I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D "RTN","DGRPECE",170,0) . S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1 "RTN","DGRPECE",171,0) I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D "RTN","DGRPECE",172,0) . S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1 "RTN","DGRPECE",173,0) I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D "RTN","DGRPECE",174,0) . S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1 "RTN","DGRPECE",175,0) I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D "RTN","DGRPECE",176,0) . S SAV("SSNREAS")=BUF("SSNREAS") "RTN","DGRPECE",177,0) I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D "RTN","DGRPECE",178,0) . S SAV("MBI")=BUF("MBI") "RTN","DGRPECE",179,0) I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix) "RTN","DGRPECE",180,0) I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change "RTN","DGRPECE",181,0) I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change "RTN","DGRPECE",182,0) I DGCNT=0 Q 0 ;no changes "RTN","DGRPECE",183,0) ;DG*750 check audit file for previous changes made during the current day "RTN","DGRPECE",184,0) I DGCNT=1 D DGAUD^DGRPAUD(DFN,.DGCNT) "RTN","DGRPECE",185,0) ;Use temp file created in DGRPAUD to get information for other changes "RTN","DGRPECE",186,0) ;that were made during the day to print on the alert. "RTN","DGRPECE",187,0) N DGAUDIEN,DGFLD,DGTYP "RTN","DGRPECE",188,0) S DGAUDIEN=0 "RTN","DGRPECE",189,0) F S DGAUDIEN=$O(^TMP("DGRPAUD",$J,DFN,DGAUDIEN)) Q:'DGAUDIEN D "RTN","DGRPECE",190,0) .S DGFLD=$P(^TMP("DGRPAUD",$J,DFN,DGAUDIEN),U,2),DGTYP=$P(^TMP("DGRPAUD",$J,DFN,DGAUDIEN),U,4) "RTN","DGRPECE",191,0) .I DGFLD=.01 S BEF("NAME")=DGTYP "RTN","DGRPECE",192,0) .I DGFLD=.09 S BEF("SSN")=DGTYP "RTN","DGRPECE",193,0) .I DGFLD=.02 S BEF("SEX")=DGTYP "RTN","DGRPECE",194,0) .I DGFLD=.03 S BEF("DOB")=DGTYP,BEF("DOB")=$$HTFM^XLFDT(BEF("DOB"),U) "RTN","DGRPECE",195,0) I DGCNT<2 Q 1 ;make one change w/o CE message "RTN","DGRPECE",196,0) I DGCNT>1 Q 2 ;more than 1 change, send CE message "RTN","DGRPECE",197,0) K ^TMP("DGRPAUD") "RTN","DGRPECE",198,0) ; "RTN","DGRPECE",199,0) WARNING() ;CE warning message "RTN","DGRPECE",200,0) ;Output 0 = exit without saving changes "RTN","DGRPECE",201,0) ; 1 = send alert and save "RTN","DGRPECE",202,0) W !!,?25,"**WARNING!!**" "RTN","DGRPECE",203,0) W !!,"The edits you are about to make, may potentially change the identity of" "RTN","DGRPECE",204,0) W !,"this patient. Please verify that you have selected the correct patient" "RTN","DGRPECE",205,0) W !,"and ensure that supporting documentation exists for these changes. If" "RTN","DGRPECE",206,0) W !,"you continue with these edits, an alert will be generated and sent to" "RTN","DGRPECE",207,0) W !,"your Supervisor and ADPAC, notifying them of the changes." "RTN","DGRPECE",208,0) N DIR,DGANS,Y "RTN","DGRPECE",209,0) S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:" "RTN","DGRPECE",210,0) S DIR("B")="NO" D ^DIR K DIR S DGANS=Y "RTN","DGRPECE",211,0) S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert "RTN","DGRPECE",212,0) Q DGANS "RTN","DGRPECE",213,0) ; "RTN","DGRPECE",214,0) ALERT ;Queue alert "RTN","DGRPECE",215,0) X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN "RTN","DGRPECE",216,0) F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)="" "RTN","DGRPECE",217,0) S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD Q "RTN","DGRPECE",218,0) ;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE) "RTN","DGRPECE",219,0) Q "VER") 8.0^22.0 "BLD",7935,6) ^716 **END** **END**