EMERGENCY Released DG*5.3*585 SEQ #557 Extracted from mail message **KIDS**:DG*5.3*585^ **INSTALL NAME** DG*5.3*585 "BLD",5989,0) DG*5.3*585^REGISTRATION^0^3050202^y "BLD",5989,4,0) ^9.64PA^^ "BLD",5989,"KRN",0) ^9.67PA^8989.52^19 "BLD",5989,"KRN",.4,0) .4 "BLD",5989,"KRN",.401,0) .401 "BLD",5989,"KRN",.402,0) .402 "BLD",5989,"KRN",.403,0) .403 "BLD",5989,"KRN",.5,0) .5 "BLD",5989,"KRN",.84,0) .84 "BLD",5989,"KRN",3.6,0) 3.6 "BLD",5989,"KRN",3.8,0) 3.8 "BLD",5989,"KRN",9.2,0) 9.2 "BLD",5989,"KRN",9.8,0) 9.8 "BLD",5989,"KRN",9.8,"NM",0) ^9.68A^15^14 "BLD",5989,"KRN",9.8,"NM",1,0) DG1010S1^^0^B34252357 "BLD",5989,"KRN",9.8,"NM",2,0) DGENRPD2^^0^B39967881 "BLD",5989,"KRN",9.8,"NM",3,0) DGENRPT4^^0^B53771812 "BLD",5989,"KRN",9.8,"NM",4,0) DGMTO1^^0^B23209812 "BLD",5989,"KRN",9.8,"NM",5,0) DGPREBJ^^0^B16699456 "BLD",5989,"KRN",9.8,"NM",6,0) DGPREBJ1^^0^B40065727 "BLD",5989,"KRN",9.8,"NM",7,0) DGRP14^^0^B4523776 "BLD",5989,"KRN",9.8,"NM",9,0) DGRPD^^0^B62383955 "BLD",5989,"KRN",9.8,"NM",10,0) VAFCCCAP^^0^B23708832 "BLD",5989,"KRN",9.8,"NM",11,0) VAFCCOPT^^0^B12640858 "BLD",5989,"KRN",9.8,"NM",12,0) VAFHCCAP^^0^B19098716 "BLD",5989,"KRN",9.8,"NM",13,0) VAFHCOPT^^0^B9367770 "BLD",5989,"KRN",9.8,"NM",14,0) VAFHUTL^^0^B21137485 "BLD",5989,"KRN",9.8,"NM",15,0) DGRPC^^0^B24632795 "BLD",5989,"KRN",9.8,"NM","B","DG1010S1",1) "BLD",5989,"KRN",9.8,"NM","B","DGENRPD2",2) "BLD",5989,"KRN",9.8,"NM","B","DGENRPT4",3) "BLD",5989,"KRN",9.8,"NM","B","DGMTO1",4) "BLD",5989,"KRN",9.8,"NM","B","DGPREBJ",5) "BLD",5989,"KRN",9.8,"NM","B","DGPREBJ1",6) "BLD",5989,"KRN",9.8,"NM","B","DGRP14",7) "BLD",5989,"KRN",9.8,"NM","B","DGRPC",15) "BLD",5989,"KRN",9.8,"NM","B","DGRPD",9) "BLD",5989,"KRN",9.8,"NM","B","VAFCCCAP",10) "BLD",5989,"KRN",9.8,"NM","B","VAFCCOPT",11) "BLD",5989,"KRN",9.8,"NM","B","VAFHCCAP",12) "BLD",5989,"KRN",9.8,"NM","B","VAFHCOPT",13) "BLD",5989,"KRN",9.8,"NM","B","VAFHUTL",14) "BLD",5989,"KRN",19,0) 19 "BLD",5989,"KRN",19.1,0) 19.1 "BLD",5989,"KRN",101,0) 101 "BLD",5989,"KRN",409.61,0) 409.61 "BLD",5989,"KRN",771,0) 771 "BLD",5989,"KRN",870,0) 870 "BLD",5989,"KRN",8989.51,0) 8989.51 "BLD",5989,"KRN",8989.52,0) 8989.52 "BLD",5989,"KRN",8994,0) 8994 "BLD",5989,"KRN","B",.4,.4) "BLD",5989,"KRN","B",.401,.401) "BLD",5989,"KRN","B",.402,.402) "BLD",5989,"KRN","B",.403,.403) "BLD",5989,"KRN","B",.5,.5) "BLD",5989,"KRN","B",.84,.84) "BLD",5989,"KRN","B",3.6,3.6) "BLD",5989,"KRN","B",3.8,3.8) "BLD",5989,"KRN","B",9.2,9.2) "BLD",5989,"KRN","B",9.8,9.8) "BLD",5989,"KRN","B",19,19) "BLD",5989,"KRN","B",19.1,19.1) "BLD",5989,"KRN","B",101,101) "BLD",5989,"KRN","B",409.61,409.61) "BLD",5989,"KRN","B",771,771) "BLD",5989,"KRN","B",870,870) "BLD",5989,"KRN","B",8989.51,8989.51) "BLD",5989,"KRN","B",8989.52,8989.52) "BLD",5989,"KRN","B",8994,8994) "BLD",5989,"QUES",0) ^9.62^^ "BLD",5989,"REQB",0) ^9.611^2^1 "BLD",5989,"REQB",2,0) DG*5.3*568^2 "BLD",5989,"REQB","B","DG*5.3*568",2) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 585^3050202 "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") YES "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") YES "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") 14 "RTN","DG1010S1") 0^1^B34252357 "RTN","DG1010S1",1,0) DG1010S1 ;ALB/MRL/EG - SUPPLEMENTAL DATA SHEET FOR 10-10 ; 02/02/2005 "RTN","DG1010S1",2,0) ;;5.3;Registration;**606,568,585**;Aug 13, 1993 "RTN","DG1010S1",3,0) ;;MAS VERSION 5.1; "RTN","DG1010S1",4,0) ; "RTN","DG1010S1",5,0) ;INPUT: DFN = IEN OF PATIENT FILE "RTN","DG1010S1",6,0) ; DFN1 = INVERSE DISPOSTION TIME "RTN","DG1010S1",7,0) EN ; "RTN","DG1010S1",8,0) S DGLDOUBL="",$P(DGLDOUBL,"=",132)="" "RTN","DG1010S1",9,0) S DGLSUP="",$P(DGLSUP,"- ",62)="",$P(DGLSUP,"- ",43)=" |" "RTN","DG1010S1",10,0) S DGLSUP1="",$P(DGLSUP1,"-",123)="",$P(DGLSUP1,"-",86)="|" "RTN","DG1010S1",11,0) F I="INE","DIS",0,.15,.24,.361 S DGP(I)=$G(^DPT(DFN,I)) "RTN","DG1010S1",12,0) S DGD=$G(^DPT(DFN,"DIS",DFN1,0)),Y=$P(DGD,U,1) X ^DD("DD") S DGAP=Y,DGCLK=$S($D(^VA(200,+$P(DGD,U,5),0)):$S($P(^(0),U,2)]"":$P(^(0),U,2)_"/"_$P(DGD,U,5),1:"unk/"_$P(DGD,U,5)),1:"unspecified"),DGNAM=$P(DGP(0),U,1) "RTN","DG1010S1",13,0) S DGSS=$P(DGP(0),U,9),DGSS=$E(DGSS,1,3)_"-"_$E(DGSS,4,5)_"-"_$E(DGSS,6,10) "RTN","DG1010S1",14,0) S DGLDOUBL=$E(DGLDOUBL,1,127) "RTN","DG1010S1",15,0) I $$FIRST^DGUTL G Q^DG1010S2 "RTN","DG1010S1",16,0) W !?5,DGLDOUBL,!?5 "RTN","DG1010S1",17,0) S X=$$SITE^VASITE W $S((+X=-1):"FACILITY NOT IDENTIFIED",1:$P(X,U,2)_" ("_$P(X,U,3)_")") "RTN","DG1010S1",18,0) W ?105,"SUPPLEMENTAL DATA SHEET",!?5,DGLDOUBL,!?5,"1. Applicant's Name: ",DGNAM,?90,"| 2. SSN: ",DGSS,!?5,DGLSUP1,!?5,"3. Other Name(s): " "RTN","DG1010S1",19,0) S I1="" F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:I'>0 S I1=1,DGD=$P(^(I,0),U,1),DGD(1)=$P(^(0),U,2),DGD=DGD_$S($L(DGD(1)):" ("_$E(DGD(1),1,3)_"-"_$E(DGD(1),4,5)_"-"_$E(DGD(1),6,10)_")",1:"")_"; " W:(128-$X)<$L(DGD) !?9 W DGD "RTN","DG1010S1",20,0) W:'I1 "NO ALIAS' ON FILE" K DGD,I,I1 S DGD=$S($L($P(DGP(0),U,10)):$P(DGP(0),U,10),1:"NO REMARKS CURRENTLY ENTERED FOR THIS APPLICANT") W !?5,DGLSUP1,!?5,"4. Remarks: ",DGD,!?5,DGLSUP1 "RTN","DG1010S1",21,0) S DGD=DGP(.24) W !?5,"5. Fathers Name: ",$S($L($P(DGD,U,1)):$P(DGD,U,1),1:"NOT SPECIFIED"),?90,"|" "RTN","DG1010S1",22,0) W !?9,"Mothers Name: ",$S($L($P(DGD,U,2)):$P(DGD,U,2),1:"NOT SPECIFIED"),?90,"|",!?9,"Mothers Maiden Name: ",$S($L($P(DGD,U,3)):$P(DGD,U,3),1:"NOT SPECIFIED"),?90,"|",!?5,DGLSUP1 "RTN","DG1010S1",23,0) N DGARRAY,I,SDOUT,CLIEN,APTDT "RTN","DG1010S1",24,0) W !?5,"6a. Enrollment Clinic(s): " S I1="" F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:I'>0 I $P(^(I,0),U,2)'="I" S I1=I1+1,DGD=$S($D(^SC(+^(0),0)):$P(^(0),U,1)_", ",1:"") W:(128-$X)<$L(DGD) !?9 W DGD "RTN","DG1010S1",25,0) W:'I1 "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME" K DGD,I,I1 W !?5,DGLSUP,!?5,"6b. Future Appointments: " S I1="",I2=DT_".9999" "RTN","DG1010S1",26,0) S DGARRAY("FLDS")="1;2",DGARRAY(4)=DFN,I=$$SDAPI^SDAMA301(.DGARRAY) "RTN","DG1010S1",27,0) ;it's not clear if it is an error or clinic or patient "RTN","DG1010S1",28,0) ;if an error,there will be no lower subscripts eg 01/20/2005 "RTN","DG1010S1",29,0) I $D(^TMP($J,"SDAMA301",101))=1 S I1=1,DGD="** Appointment Database Unavailable **" "RTN","DG1010S1",30,0) I $D(^TMP($J,"SDAMA301",101))'=1 D "RTN","DG1010S1",31,0) .S (DGD,CLIEN)="" F S CLIEN=$O(^TMP($J,"SDAMA301",DFN,CLIEN)) Q:'CLIEN D "RTN","DG1010S1",32,0) ..S APTDT=DT F S APTDT=$O(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT)) Q:'APTDT D "RTN","DG1010S1",33,0) ...S SDOUT=^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),I1=1,DGD=DGD_$P($P(SDOUT,U,2),";",2)_" ("_$$FMTE^DILIBF($P(SDOUT,U),"5U")_")," "RTN","DG1010S1",34,0) W:(128-$X)<$L(DGD) !?9 W DGD "RTN","DG1010S1",35,0) K DGARRAY,^TMP($J,"SDAMA301"),SDOUT,CLIEN,APTDT "RTN","DG1010S1",36,0) W:'I1 "NO PENDING APPOINTMENTS ON FILE" W !?5,DGLSUP1,!?5,"7a. Last Admission: " "RTN","DG1010S1",37,0) S DGAD=$S('$D(^DPT(DFN,.1)):0,'$L(^DPT(DFN,.1)):0,1:1),DGD=$O(^DGPM("ATID1",DFN,+$S(DGAD:$O(^DGPM("ATID1",DFN,0)),1:0))) I DGD'>0 W "NO PREVIOUS ADMISSIONS TO THIS FACILITY ON FILE" G EL "RTN","DG1010S1",38,0) S DGD=$O(^DGPM("ATID1",DFN,DGD,0)) I $S('$D(^DGPM(+DGD,0)):1,'$D(^DGPT(+$P(^(0),"^",16),0)):1,1:0) W "LAST ADMISSION PTF DATA NO LONGER STORED" G EL "RTN","DG1010S1",39,0) S DGD=+$P(^DGPM(+DGD,0),"^",16),Y=+^(0),DGDAT=Y "RTN","DG1010S1",40,0) X ^DD("DD") W Y S Y=$P($S($D(^DGPT(DGD,70)):^(70),1:0),U,1) X ^DD("DD") W:Y]"" " (DISCHARGED '"_Y_"')" W !?5,DGLSUP,!?5,"7b. Discharge Diagnosis(es): " S I1=$S($D(^DGPT(DGD,"M",1,0)):^(0),1:0) "RTN","DG1010S1",41,0) S I3="" F I=5:1:15 I I'=10 S I2=$P(I1,U,I) Q:'I2 S I3=1,I2=$$ICDDX^ICDCODE(I2,DGDAT),I2=$S(+I2>0:"("_$P(I2,U,2)_")-"_$P(I2,U,4)_"; ",1:"") W:(128-$X)<$L(I2) !?9 W I2 "RTN","DG1010S1",42,0) W:'I3 "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD YET",!?5,DGLSUP S DGD(1)=$S($D(^DGPT(DGD,70)):^(70),1:0),X="UNSPECIFIED",I2=$$ICDDX^ICDCODE(+$P(DGD(1),U,11),DGDAT),X=$S('DGD(1):X,+I2>0:"("_$P(I2,U,2)_")-"_$P(I2,U,4),1:X) "RTN","DG1010S1",43,0) W !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. Diagnosis Responsible for Greatest Length of Stay: " S X="UNSPECIFIED",I2=$$ICDDX^ICDCODE(+$P(DGD(1),U,10),DGDAT),X=$S('DGD(1):X,+I2>0:"("_$P(I2,U,2)_")-"_$P(I2,U,4),1:X) W X "RTN","DG1010S1",44,0) EL W !?5,DGLSUP1 S DGD=DGP(.361),DGD(1)=$P(DGD,U,5),DGD(2)=$P(DGD,U,6),Y=$P(DGD,U,2),DGD=$P(DGD,U,1),DGD(1)=$S($L(DGD(1)):DGD(1),'$L(DGD):"NOT APPLICABLE",1:"NOT VERIFIED") "RTN","DG1010S1",45,0) S DGD(2)=$S(+DGD(2):$S($D(^VA(200,+DGD(2),0)):$P(^(0),U,1),1:"UNKNOWN"),'$L(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED") X:+Y ^DD("DD") S Y=$S($L(Y):Y,'$L(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED") "RTN","DG1010S1",46,0) W !?5,"8. Eligibility Status: ",$S(DGD="P":"PENDING VERIFICATION",DGD="R":"PENDING RE-VERIFICATION",DGD="V":"VERIFIED",1:"UNKNOWN OR NONE"),?90,"| Status Date: ",Y,!?9,"Verification Method: ",DGD(1),?90,"| By: ",DGD(2) "RTN","DG1010S1",47,0) S Y=$P(DGP(.15),U,2),DGD=DGP("INE") X:+Y ^DD("DD") S DGEL=$S('$L(Y)!(Y=0):1,1:0),Y=$S('DGEL:Y,1:"ELIGIBLE APPLICANT -- NOT APPLICABLE") W !?9,"Ineligible Date: ",Y I DGEL F I=1:1:4 S DGD(I)="NOT APPLICABLE" "RTN","DG1010S1",48,0) G:DGEL C S DGD(1)=$P(DGD,U,1),DGD(1)=$S(DGD(1)=1:"VAMC",DGD(1)=2:"REGIONAL OFFICE",DGD(2)=3:"RPC",1:"UNKNOWN"),DGD(2)=$S($L($P(DGD,U,3)):$P(DGD,U,3),1:"CITY UNKNOWN"),DGD(3)=$S($D(^DIC(5,+$P(DGD,U,4),0)):$P(^(0),U,1),1:"STATE UNKNOWN") "RTN","DG1010S1",49,0) S DGD(4)=$S($P(DGD,U,6)]"":$P(DGD,U,6),1:"VARO DECISION UNKNOWN") "RTN","DG1010S1",50,0) C W ?90,"| TWX Source: ",DGD(1),!?9,"TWX City: ",DGD(2),?90,"| TWX State: ",$E(DGD(3),1,26),!?9,"VARO Decision: ",DGD(4),!?5,DGLSUP1 "RTN","DG1010S1",51,0) K DGAD,DGD,DGEL,I,I1,I2,Y,DGDAT G ^DG1010S2 "RTN","DGENRPD2") 0^2^B39967881 "RTN","DGENRPD2",1,0) DGENRPD2 ;ALB/CJM/EG -Veteran with Future Appts and no Enrollment App Report - Continue 01/19/2005 ; 1/20/05 1:27pm "RTN","DGENRPD2",2,0) ;;5.3;Registration;**147,232,568,585**;Aug 13,1993 "RTN","DGENRPD2",3,0) ; "RTN","DGENRPD2",4,0) PRINT ; "RTN","DGENRPD2",5,0) N CRT,QUIT,PAGE,SUBSCRPT "RTN","DGENRPD2",6,0) K ^TMP($J) "RTN","DGENRPD2",7,0) S QUIT=0 "RTN","DGENRPD2",8,0) S PAGE=0 "RTN","DGENRPD2",9,0) S CRT=$S($E(IOST,1,2)="C-":1,1:0) "RTN","DGENRPD2",10,0) ; "RTN","DGENRPD2",11,0) D GETPAT "RTN","DGENRPD2",12,0) U IO "RTN","DGENRPD2",13,0) I CRT,PAGE=0 W @IOF "RTN","DGENRPD2",14,0) S PAGE=1 "RTN","DGENRPD2",15,0) D HEADER "RTN","DGENRPD2",16,0) F SUBSCRPT="STEP2","NOENREC" D "RTN","DGENRPD2",17,0) .D PATIENTS(SUBSCRPT) "RTN","DGENRPD2",18,0) I CRT,'QUIT D PAUSE "RTN","DGENRPD2",19,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","DGENRPD2",20,0) D ^%ZISC "RTN","DGENRPD2",21,0) ; "RTN","DGENRPD2",22,0) K ^TMP($J) "RTN","DGENRPD2",23,0) Q "RTN","DGENRPD2",24,0) LINE(LINE) ; "RTN","DGENRPD2",25,0) ;Description: prints a line. First prints header if at end of page. "RTN","DGENRPD2",26,0) ; "RTN","DGENRPD2",27,0) I CRT,($Y>(IOSL-4)) D "RTN","DGENRPD2",28,0) .D PAUSE "RTN","DGENRPD2",29,0) .Q:QUIT "RTN","DGENRPD2",30,0) .W @IOF "RTN","DGENRPD2",31,0) .D HEADER "RTN","DGENRPD2",32,0) .W LINE "RTN","DGENRPD2",33,0) ; "RTN","DGENRPD2",34,0) E I ('CRT),($Y>(IOSL-2)) D "RTN","DGENRPD2",35,0) .W @IOF "RTN","DGENRPD2",36,0) .D HEADER "RTN","DGENRPD2",37,0) .W LINE "RTN","DGENRPD2",38,0) ; "RTN","DGENRPD2",39,0) E W !,LINE "RTN","DGENRPD2",40,0) Q "RTN","DGENRPD2",41,0) ; "RTN","DGENRPD2",42,0) GETPAT ; "RTN","DGENRPD2",43,0) ; Description: Gets patients to include in the report "RTN","DGENRPD2",44,0) N BEGIN,END,DGARRAY,SDCNT,CATEGORY,DIVISION "RTN","DGENRPD2",45,0) S BEGIN=DGENRP("BEGIN")-.1,END=DGENRP("END")+.1,DGARRAY(1)=BEGIN_";"_END "RTN","DGENRPD2",46,0) S DGARRAY("FLDS")="3;10",SDCNT=$$SDAPI^SDAMA301(.DGARRAY) "RTN","DGENRPD2",47,0) ; "RTN","DGENRPD2",48,0) ;there must be subscripts underneath the 101 level to be a "RTN","DGENRPD2",49,0) ;valid appointment, else it is an error eg 01/20/2005 "RTN","DGENRPD2",50,0) ; Appointment Database is Unavailable "RTN","DGENRPD2",51,0) I $D(^TMP($J,"SDAMA301",101))=1 G ERR101 "RTN","DGENRPD2",52,0) ; "RTN","DGENRPD2",53,0) ; Get All records for report "RTN","DGENRPD2",54,0) I DGENRP("ALL") D "RTN","DGENRPD2",55,0) .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D "RTN","DGENRPD2",56,0) ..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C" "RTN","DGENRPD2",57,0) ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D "RTN","DGENRPD2",58,0) ...S DIVISION=$P($G(^SC(CLINIC,0)),U,15) "RTN","DGENRPD2",59,0) ...S:'DIVISION DIVISION=$O(^DG(40.8,0)) "RTN","DGENRPD2",60,0) ...D VALREC(CLINIC,DFN) "RTN","DGENRPD2",61,0) ; "RTN","DGENRPD2",62,0) ; Get records for specified Divisions only "RTN","DGENRPD2",63,0) I $O(DGENRP("DIVISION",0)) D "RTN","DGENRPD2",64,0) .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D "RTN","DGENRPD2",65,0) ..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C" "RTN","DGENRPD2",66,0) ..S DIVISION=$P($G(^SC(CLINIC,0)),U,15) "RTN","DGENRPD2",67,0) ..S:'DIVISION DIVISION=$O(^DG(40.8,0)) "RTN","DGENRPD2",68,0) ..Q:'DIVISION!('$D(DGENRP("DIVISION",DIVISION))) "RTN","DGENRPD2",69,0) ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D VALREC(CLINIC,DFN) "RTN","DGENRPD2",70,0) ; "RTN","DGENRPD2",71,0) ; Get records for specified Clinics only "RTN","DGENRPD2",72,0) I $O(DGENRP("CLINIC",0)) D "RTN","DGENRPD2",73,0) .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D "RTN","DGENRPD2",74,0) ..Q:'CLINIC!('$D(DGENRP("CLINIC",CLINIC))) "RTN","DGENRPD2",75,0) ..Q:($P($G(^SC(CLINIC,0)),U,3)'="C") "RTN","DGENRPD2",76,0) ..S DIVISION=$P($G(^SC(CLINIC,0)),U,15) "RTN","DGENRPD2",77,0) ..S:'DIVISION DIVISION=$O(^DG(40.8,0)) "RTN","DGENRPD2",78,0) ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D VALREC(CLINIC,DFN) "RTN","DGENRPD2",79,0) ; "RTN","DGENRPD2",80,0) K DGARRAY,^TMP($J,"SDAMA301"),SDCNT "RTN","DGENRPD2",81,0) Q "RTN","DGENRPD2",82,0) ; "RTN","DGENRPD2",83,0) ERR101 S NAM="**Appointment Database is Unavailable**" "RTN","DGENRPD2",84,0) ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN) "RTN","DGENRPD2",85,0) S ^TMP($J,"NOENREC"," ",NAM," ",DT," ")="" "RTN","DGENRPD2",86,0) K DGARRAY,^TMP($J,"SDAMA301"),SDCNT,NAM "RTN","DGENRPD2",87,0) Q "RTN","DGENRPD2",88,0) ; "RTN","DGENRPD2",89,0) VALREC(CLINIC,DFN) ; "RTN","DGENRPD2",90,0) ; "RTN","DGENRPD2",91,0) N APPT,STATUS,JUSTONCE S JUSTONCE=0 "RTN","DGENRPD2",92,0) S APPT=0 F S APPT=$O(^TMP($J,"SDAMA301",CLINIC,DFN,APPT)) Q:'APPT!(JUSTONCE) D "RTN","DGENRPD2",93,0) .S JUSTONCE=+$G(DGENRP("JUSTONCE")) "RTN","DGENRPD2",94,0) .; Exclude certain appointment statuses "RTN","DGENRPD2",95,0) .S STATUS=$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U,3),";") "RTN","DGENRPD2",96,0) .Q:"^N^NA^C^CA^PC^PCA^"[(U_STATUS_U) "RTN","DGENRPD2",97,0) .; "RTN","DGENRPD2",98,0) .; Don't include enrolled veterans or ones that have pending apps "RTN","DGENRPD2",99,0) .S CATEGORY=$$CATEGORY^DGENA4(DFN) "RTN","DGENRPD2",100,0) .I (CATEGORY="E")!(CATEGORY="P") Q "RTN","DGENRPD2",101,0) .; "RTN","DGENRPD2",102,0) .; Exclude if not an eligible veteran (can not enroll) "RTN","DGENRPD2",103,0) .Q:'$$VET^DGENPTA(DFN) "RTN","DGENRPD2",104,0) .; "RTN","DGENRPD2",105,0) .D SETTMP(CLINIC,DFN,APPT) "RTN","DGENRPD2",106,0) Q "RTN","DGENRPD2",107,0) ; "RTN","DGENRPD2",108,0) SETTMP(CLINIC,DFN,APPT) ; "RTN","DGENRPD2",109,0) ; NOENREC is for patients without enrollment records "RTN","DGENRPD2",110,0) ; SITE2 is for other excluded enrollment records "RTN","DGENRPD2",111,0) ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN) "RTN","DGENRPD2",112,0) ; "RTN","DGENRPD2",113,0) N DIVNAME,CLNAME "RTN","DGENRPD2",114,0) S DIVNAME=$S(DIVISION:$P($$SITE^VASITE(APPT\1,DIVISION),U,2),1:" ") "RTN","DGENRPD2",115,0) S CLNAME=$P($G(^SC(CLINIC,0)),"^") "RTN","DGENRPD2",116,0) S:CLNAME="" CLNAME=" " "RTN","DGENRPD2",117,0) ; "RTN","DGENRPD2",118,0) I $$FINDCUR^DGENA(DFN)="" S ^TMP($J,"NOENREC",DIVNAME,CLNAME,CATEGORY,APPT,DFN)="" Q "RTN","DGENRPD2",119,0) S ^TMP($J,"STEP2",DIVNAME,CLNAME,CATEGORY,APPT,DFN)=$$STATUS^DGENA(DFN)_U_$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U,10),";",2) "RTN","DGENRPD2",120,0) Q "RTN","DGENRPD2",121,0) ; "RTN","DGENRPD2",122,0) HEADER ; "RTN","DGENRPD2",123,0) ;Description: Prints the report header. "RTN","DGENRPD2",124,0) ; "RTN","DGENRPD2",125,0) N LINE "RTN","DGENRPD2",126,0) I $Y>1 W @IOF "RTN","DGENRPD2",127,0) W !,"Appointments for Veterans with no Enrollment Application" "RTN","DGENRPD2",128,0) W:DGENRP("BEGIN") ?70,"Date Range: "_$$FMTE^XLFDT(DGENRP("BEGIN"))_" to "_$$FMTE^XLFDT($G(DGENRP("END"))) "RTN","DGENRPD2",129,0) W ?120,"Page ",PAGE "RTN","DGENRPD2",130,0) S PAGE=PAGE+1 "RTN","DGENRPD2",131,0) W ! "RTN","DGENRPD2",132,0) W ?70," Run Date: "_$$FMTE^XLFDT(DT) "RTN","DGENRPD2",133,0) W ! "RTN","DGENRPD2",134,0) ; "RTN","DGENRPD2",135,0) W !,"Name",?39,"PatientID",?57,"DOB",?70,"Appt Dt/Tm",?90,"EnrollStatus",?121,"Enroll Cat" "RTN","DGENRPD2",136,0) S $P(LINE,"-",132)="-" "RTN","DGENRPD2",137,0) W !,LINE,! "RTN","DGENRPD2",138,0) Q "RTN","DGENRPD2",139,0) ; "RTN","DGENRPD2",140,0) PAUSE ; "RTN","DGENRPD2",141,0) ;Description: Screen pause. Sets QUIT=1 if user decides to quit. "RTN","DGENRPD2",142,0) ; "RTN","DGENRPD2",143,0) N DIR,X,Y "RTN","DGENRPD2",144,0) F Q:$Y>(IOSL-3) W ! "RTN","DGENRPD2",145,0) S DIR(0)="E" "RTN","DGENRPD2",146,0) D ^DIR "RTN","DGENRPD2",147,0) I ('(+Y))!$D(DIRUT) S QUIT=1 "RTN","DGENRPD2",148,0) Q "RTN","DGENRPD2",149,0) ; "RTN","DGENRPD2",150,0) PATIENTS(SUBSCRPT) ; "RTN","DGENRPD2",151,0) ;Description: Prints list of patients "RTN","DGENRPD2",152,0) ; "RTN","DGENRPD2",153,0) N NODE,DIVISION,CLINIC,TIME,PATIENT,DGPAT,APPTYPE,ENRSTAT,CATEGORY "RTN","DGENRPD2",154,0) ; "RTN","DGENRPD2",155,0) ; "RTN","DGENRPD2",156,0) S DIVISION="" "RTN","DGENRPD2",157,0) F S DIVISION=$O(^TMP($J,SUBSCRPT,DIVISION)) Q:DIVISION="" D Q:QUIT "RTN","DGENRPD2",158,0) .D LINE(" ") Q:QUIT "RTN","DGENRPD2",159,0) .D LINE($$LJ(" ",40)_"DIVISION: "_DIVISION) Q:QUIT "RTN","DGENRPD2",160,0) .D LINE(" ") Q:QUIT "RTN","DGENRPD2",161,0) .S CLINIC="" "RTN","DGENRPD2",162,0) .F S CLINIC=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC)) Q:CLINIC="" D Q:QUIT "RTN","DGENRPD2",163,0) ..D LINE(" ") Q:QUIT "RTN","DGENRPD2",164,0) ..D LINE("CLINIC: "_$$LJ(CLINIC,40)_$$LJ(" ",40)_"DIVISION: "_DIVISION) "RTN","DGENRPD2",165,0) ..Q:QUIT "RTN","DGENRPD2",166,0) ..S CATEGORY="" "RTN","DGENRPD2",167,0) ..F S CATEGORY=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY)) Q:CATEGORY="" D Q:QUIT "RTN","DGENRPD2",168,0) ...D LINE(" ") Q:QUIT "RTN","DGENRPD2",169,0) ...S TIME=0 "RTN","DGENRPD2",170,0) ...F S TIME=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME)) Q:'TIME D Q:QUIT "RTN","DGENRPD2",171,0) ....S DFN=0 "RTN","DGENRPD2",172,0) ....F S DFN=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME,DFN)) Q:'DFN D Q:QUIT "RTN","DGENRPD2",173,0) .....S NODE=$G(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME,DFN)) "RTN","DGENRPD2",174,0) .....S ENRSTAT=$P(NODE,"^") "RTN","DGENRPD2",175,0) .....S APPTYPE=$P(NODE,"^",2) "RTN","DGENRPD2",176,0) .....Q:'$$GET^DGENPTA(DFN,.DGPAT) "RTN","DGENRPD2",177,0) .....S LINE=$$LJ(DGPAT("NAME"),37)_" "_$$LJ(DGPAT("PID"),15)_" " "RTN","DGENRPD2",178,0) .....S LINE=LINE_$$LJ($$DATE(DGPAT("DOB")),12)_" " "RTN","DGENRPD2",179,0) .....S LINE=LINE_$$LJ($$DATE(TIME),20) "RTN","DGENRPD2",180,0) .....S LINE=LINE_" "_$$LJ($S(ENRSTAT="":"NO ENROLLMENT RECORD",1:$$EXT^DGENU("STATUS",ENRSTAT)),28) "RTN","DGENRPD2",181,0) .....S LINE=LINE_$$LJ(" ",2)_$$EXTCAT^DGENA4(CATEGORY) "RTN","DGENRPD2",182,0) .....D LINE(LINE) "RTN","DGENRPD2",183,0) .....Q:QUIT "RTN","DGENRPD2",184,0) Q "RTN","DGENRPD2",185,0) ; "RTN","DGENRPD2",186,0) DATE(DATE) ; "RTN","DGENRPD2",187,0) Q $$FMTE^XLFDT(DATE,"1") "RTN","DGENRPD2",188,0) ; "RTN","DGENRPD2",189,0) LJ(STRING,LENGTH) ; "RTN","DGENRPD2",190,0) Q $$LJ^XLFSTR($E(STRING,1,LENGTH),LENGTH) "RTN","DGENRPT4") 0^3^B53771812 "RTN","DGENRPT4",1,0) DGENRPT4 ;ALB/DW,LBD/EG - EGT Actual Detailed Impact Report ; 1/20/05 1:04pm "RTN","DGENRPT4",2,0) ;;5.3;Registration;**232,306,417,456,491,513,568,585**;Aug 13,1993 "RTN","DGENRPT4",3,0) ; "RTN","DGENRPT4",4,0) ; "RTN","DGENRPT4",5,0) ENPT ;Actual Detailed Report selected. "RTN","DGENRPT4",6,0) K ^TMP($J,"BY4"),^TMP($J,"CNT4") "RTN","DGENRPT4",7,0) N INFAP,BDT,EDT S (INFAP,BDT,EDT)="" "RTN","DGENRPT4",8,0) D RPDT I BDT="^"!(EDT="^")!($D(DTOUT)) Q "RTN","DGENRPT4",9,0) D INFAP I INFAP="^"!($D(DTOUT)) Q "RTN","DGENRPT4",10,0) N EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,L,BY,DIC,FLDS,DHD,DIOEND,X,DFN,PSSN,FCTY,DIOBEG,VASD,VAERR,RLEGT,ENRDT "RTN","DGENRPT4",11,0) S (EGT,EGTSUB,EGTEDT,EGTLDT,EGTTP,FCTY,RLEGT)="" "RTN","DGENRPT4",12,0) W !!,"*** This report requires a 132 column printer. ***",!! "RTN","DGENRPT4",13,0) S DIC="^DGEN(27.11," "RTN","DGENRPT4",14,0) S DIOBEG="D PRESORT^DGENRPT4" "RTN","DGENRPT4",15,0) S BY(0)="^TMP($J,""BY4"",",L(0)=3,L=0 "RTN","DGENRPT4",16,0) S FLDS="D PT^DGENRPT4 W X;C0;L20,W PSSN;C22;L10,D EP^DGENRPT4 W X;C33;L2,D ENRED^DGENRPT4 W X;C37;L10,D ENRST^DGENRPT4 W X;C49;L12" "RTN","DGENRPT4",17,0) I INFAP=1 D "RTN","DGENRPT4",18,0) . S FLDS(2)="D WRD^DGENRPT4 W X;C63;L15;""WARD"",D FAP1^DGENRPT4 W X;C80;L31,D PCPVD^DGENRPT4 W X;C110;L10,D PFCLTY^DGENRPT4 W X;C121;L11" "RTN","DGENRPT4",19,0) . S DHD="W ?0 D DETHD1^DGENRPT4" "RTN","DGENRPT4",20,0) I INFAP=0 D "RTN","DGENRPT4",21,0) . S FLDS(2)="D WRD^DGENRPT4 W X;C63;L15;""WARD"",D FAP0^DGENRPT4 W X;C80;L31,D PCPVD^DGENRPT4 W X;C88;L10,D PFCLTY^DGENRPT4 W X;C100;L12" "RTN","DGENRPT4",22,0) . S DHD="W ?0 D DETHD0^DGENRPT4" "RTN","DGENRPT4",23,0) S DIOEND="D END^DGENRPT4" "RTN","DGENRPT4",24,0) D EN1^DIP "RTN","DGENRPT4",25,0) D EXIT "RTN","DGENRPT4",26,0) Q "RTN","DGENRPT4",27,0) ; "RTN","DGENRPT4",28,0) INFAP ;Ask the user if Future Appointments is wanted on the report. "RTN","DGENRPT4",29,0) N DIR,X,Y "RTN","DGENRPT4",30,0) S DIR(0)="Y^1:3" "RTN","DGENRPT4",31,0) S DIR("A")="Do you want to include Future Appointments" "RTN","DGENRPT4",32,0) D ^DIR S INFAP=Y "RTN","DGENRPT4",33,0) I ($D(DTOUT)) W *7 "RTN","DGENRPT4",34,0) Q "RTN","DGENRPT4",35,0) ; "RTN","DGENRPT4",36,0) RPDT ;Ask the user the Report Begin Date and Report End Date. "RTN","DGENRPT4",37,0) N DIR,X,Y "RTN","DGENRPT4",38,0) S DIR(0)="DA^::E" "RTN","DGENRPT4",39,0) S DIR("A")="Report Begin Date: " "RTN","DGENRPT4",40,0) S DIR("?")="Please enter the Enrollment End Date as the beginning date that will be reported on." "RTN","DGENRPT4",41,0) D ^DIR S BDT=Y "RTN","DGENRPT4",42,0) I BDT="^" Q "RTN","DGENRPT4",43,0) I ($D(DTOUT)) W *7 Q "RTN","DGENRPT4",44,0) ; "RTN","DGENRPT4",45,0) RPDT2 S DIR(0)="DA^::E" "RTN","DGENRPT4",46,0) S DIR("A")="Report End Date: " "RTN","DGENRPT4",47,0) S DIR("?")="Please enter the Enrollment End Date as the end date that will be reported on. Report End Date cannot be earlier than Report Begin Date." "RTN","DGENRPT4",48,0) D ^DIR S EDT=Y "RTN","DGENRPT4",49,0) I EDT="^" Q "RTN","DGENRPT4",50,0) I ($D(DTOUT)) W *7 Q "RTN","DGENRPT4",51,0) I EDTEDT) D "RTN","DGENRPT4",83,0) ... K VADM(1),VADM(2) D DEM^VADPT S NM=VADM(1) D BYSRT "RTN","DGENRPT4",84,0) ... S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT4",PRT,PSSN)="" "RTN","DGENRPT4",85,0) I EGTSUB>4 S EGTSUB="ER" Q "RTN","DGENRPT4",86,0) S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB) "RTN","DGENRPT4",87,0) D GETAPPT^DGENRPT5("BY4") "RTN","DGENRPT4",88,0) Q "RTN","DGENRPT4",89,0) ; "RTN","DGENRPT4",90,0) EGTP ;Get patients EGT Priority. "RTN","DGENRPT4",91,0) S (PRT,PRTSUB,ABV,ENRDT)="" "RTN","DGENRPT4",92,0) S PRT=$P($G(^DGEN(27.11,IND,0)),U,7) "RTN","DGENRPT4",93,0) S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12) "RTN","DGENRPT4",94,0) S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10) "RTN","DGENRPT4",95,0) S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U) "RTN","DGENRPT4",96,0) S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) "RTN","DGENRPT4",97,0) I PRT=7!(PRT=8) D "RTN","DGENRPT4",98,0) . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB) "RTN","DGENRPT4",99,0) . S:PRTSUB="" PRTSUB="ER" "RTN","DGENRPT4",100,0) S PRT=PRT_PRTSUB "RTN","DGENRPT4",101,0) Q "RTN","DGENRPT4",102,0) ; "RTN","DGENRPT4",103,0) BYSRT ;Sort patients by last name for "BY(0)". "RTN","DGENRPT4",104,0) S ^TMP($J,"BY4",NM,DFN,IND)="" "RTN","DGENRPT4",105,0) Q "RTN","DGENRPT4",106,0) ; "RTN","DGENRPT4",107,0) PT ;Get the patient NAME and SSN "RTN","DGENRPT4",108,0) S (X,DFN,PSSN)="" K VADM(1),VADM(2) "RTN","DGENRPT4",109,0) S DFN=$P($G(^DGEN(27.11,D0,0)),U,2) "RTN","DGENRPT4",110,0) I DFN D DEM^VADPT S X=$E(VADM(1),1,20),PSSN=$P(VADM(2),U) "RTN","DGENRPT4",111,0) Q "RTN","DGENRPT4",112,0) ; "RTN","DGENRPT4",113,0) EP ;Get the patient EGT Priority. "RTN","DGENRPT4",114,0) S X="" "RTN","DGENRPT4",115,0) N PRT,PRTSUB S (PRT,PRTSUB)="" "RTN","DGENRPT4",116,0) S PRT=$P($G(^DGEN(27.11,D0,0)),U,7) "RTN","DGENRPT4",117,0) I PRT=7!(PRT=8) D "RTN","DGENRPT4",118,0) .S PRTSUB=$P($G(^DGEN(27.11,D0,0)),U,12) "RTN","DGENRPT4",119,0) .S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB) "RTN","DGENRPT4",120,0) .S:PRTSUB="" PRTSUB="ER" "RTN","DGENRPT4",121,0) .S PRT=PRT_PRTSUB "RTN","DGENRPT4",122,0) S X=PRT "RTN","DGENRPT4",123,0) Q "RTN","DGENRPT4",124,0) ; "RTN","DGENRPT4",125,0) ENRED ;Get the patient ENROLLMENT END DATE. "RTN","DGENRPT4",126,0) S X="" "RTN","DGENRPT4",127,0) S X=$P($G(^DGEN(27.11,D0,0)),U,11) "RTN","DGENRPT4",128,0) I X="" S X="N/A" Q "RTN","DGENRPT4",129,0) S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) "RTN","DGENRPT4",130,0) Q "RTN","DGENRPT4",131,0) ; "RTN","DGENRPT4",132,0) ENRST ;Get the patient ENROLLMENT STATUS. "RTN","DGENRPT4",133,0) S X="" "RTN","DGENRPT4",134,0) S X=$P($G(^DGEN(27.11,D0,0)),U,4) "RTN","DGENRPT4",135,0) S X=$P($G(^DGEN(27.15,X,0)),U,1),X=$E(X,1,12) "RTN","DGENRPT4",136,0) Q "RTN","DGENRPT4",137,0) ; "RTN","DGENRPT4",138,0) WRD ;Get the patient WARD. "RTN","DGENRPT4",139,0) S X="" K VAIP(5) "RTN","DGENRPT4",140,0) D IN5^VADPT S X=$P($G(VAIP(5)),U,2),X=$E(X,1,15) "RTN","DGENRPT4",141,0) I X="" S X="N/A" "RTN","DGENRPT4",142,0) Q "RTN","DGENRPT4",143,0) ; "RTN","DGENRPT4",144,0) FAP1 ;Get the patient FUTURE APPOINTMENTS. "RTN","DGENRPT4",145,0) N J,POP,ADT S (X,J,ADT)="",POP=0 "RTN","DGENRPT4",146,0) K ^UTILITY("VASD",$J) "RTN","DGENRPT4",147,0) ;if there is lower level data, then it is an error eg 01/20/2005 "RTN","DGENRPT4",148,0) I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q "RTN","DGENRPT4",149,0) D BLDUTL^DGENRPT5(DFN) "RTN","DGENRPT4",150,0) F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D "RTN","DGENRPT4",151,0) . S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20) "RTN","DGENRPT4",152,0) . S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1) "RTN","DGENRPT4",153,0) . S ADT=$E(ADT,4,5)_"/"_$E(ADT,6,7)_"/"_(1700+$E(ADT,1,3)) "RTN","DGENRPT4",154,0) . S X=ADT_" "_X "RTN","DGENRPT4",155,0) . I J=1 W X S X="" "RTN","DGENRPT4",156,0) . I J>1&(J<6) W !,?79,X S X="" "RTN","DGENRPT4",157,0) . I J=6 S X="" W !,?79,"More Appts" S POP=1 Q "RTN","DGENRPT4",158,0) I $D(^UTILITY("VASD",$J))=0 S X="NONE" "RTN","DGENRPT4",159,0) Q "RTN","DGENRPT4",160,0) ; "RTN","DGENRPT4",161,0) FAP0 ;See if the patient has future appointment. "RTN","DGENRPT4",162,0) S X="NO" "RTN","DGENRPT4",163,0) K ^UTILITY("VASD",$J) "RTN","DGENRPT4",164,0) ;in order to be a valid appointment, there must be "RTN","DGENRPT4",165,0) ;lower level subscripts. if not, then it is "RTN","DGENRPT4",166,0) ;an error eg 01/20/2005 "RTN","DGENRPT4",167,0) I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q "RTN","DGENRPT4",168,0) D BLDUTL^DGENRPT5(DFN) "RTN","DGENRPT4",169,0) I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES" "RTN","DGENRPT4",170,0) Q "RTN","DGENRPT4",171,0) ; "RTN","DGENRPT4",172,0) PCPVD ;Get the patient PC PROVIDER. "RTN","DGENRPT4",173,0) ;;Site must use PCMM module. "RTN","DGENRPT4",174,0) S X="" "RTN","DGENRPT4",175,0) S X=$$PCPRACT^DGSDUTL(DFN) "RTN","DGENRPT4",176,0) I X="" S X="N/A" Q "RTN","DGENRPT4",177,0) S X=$P(X,U,2),X=$E(X,1,10) "RTN","DGENRPT4",178,0) Q "RTN","DGENRPT4",179,0) ; "RTN","DGENRPT4",180,0) PFCLTY ;Get the patient PREFFERED FACILITY. "RTN","DGENRPT4",181,0) S (X,FCTY)="" "RTN","DGENRPT4",182,0) S X=$$PREF^DGENPTA(DFN,.FCTY),X=$E(FCTY,1,11) "RTN","DGENRPT4",183,0) I X="" S X="N/A" "RTN","DGENRPT4",184,0) Q "RTN","DGENRPT4",185,0) ; "RTN","DGENRPT4",186,0) DETHD ;General header for the Preliminary Detailed Report. "RTN","DGENRPT4",187,0) ;Get the date/time the report is run. "RTN","DGENRPT4",188,0) N RDT,Y,DT1,DT2 S (RDT,Y,DT1,DT2)="" "RTN","DGENRPT4",189,0) D NOW^%DTC S Y=% X ^DD("DD") "RTN","DGENRPT4",190,0) S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2) "RTN","DGENRPT4",191,0) S DT1=$$FMTE^XLFDT(BDT),DT2=$$FMTE^XLFDT(EDT) "RTN","DGENRPT4",192,0) ;Write the header. "RTN","DGENRPT4",193,0) W !,?((IOM-33)\2),"EGT Actual Detailed Impact Report" "RTN","DGENRPT4",194,0) W !,?((IOM-38-$L(DT1_DT2))\2),"Date Range of Enrollment End Date: ",DT1," - ",DT2 "RTN","DGENRPT4",195,0) W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT "RTN","DGENRPT4",196,0) W !,?((IOM-45-$L(RLEGT_EGTSUB_EGTTP_EGTEDT))\2),"EGT Setting: ",RLEGT_EGTSUB," EGT Type: ",EGTTP," EGT Effective Date: ",EGTEDT "RTN","DGENRPT4",197,0) W !,?((IOM-28-$L(EGTLDT))\2),"Date/Time Last EGT Setting: ",EGTLDT "RTN","DGENRPT4",198,0) W !!,"IMPORTANT NOTE: Actual report is based on a comparison of the EGT Setting and the Enrollment Category as provided by HEC." "RTN","DGENRPT4",199,0) Q "RTN","DGENRPT4",200,0) ; "RTN","DGENRPT4",201,0) DETHD1 ;Header for the Preliminary Detailed Report, with Future Appointments. "RTN","DGENRPT4",202,0) D DETHD "RTN","DGENRPT4",203,0) W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?109,"PC",?120,"PREF" "RTN","DGENRPT4",204,0) W !,?36,"END DATE",?48,"STATUS",?79,"APPOINTMENTS",?109,"PROVIDER",?120,"FACILITY",!! "RTN","DGENRPT4",205,0) Q "RTN","DGENRPT4",206,0) ; "RTN","DGENRPT4",207,0) DETHD0 ;Header for the Preliminary Detailed Report, no Future Appointments. "RTN","DGENRPT4",208,0) D DETHD "RTN","DGENRPT4",209,0) W !!,"NAME",?21,"SSN",?32,"EP",?36,"ENROLLMENT",?48,"ENROLLMENT",?62,"WARD",?79,"FUTURE",?87,"PC",?99,"PREF" "RTN","DGENRPT4",210,0) W !,?36,"END DATE",?48,"STATUS",?79,"APPTS",?87,"PROVIDER",?99,"FACILITY",!! "RTN","DGENRPT4",211,0) Q "RTN","DGENRPT4",212,0) ; "RTN","DGENRPT4",213,0) END ;At the end of the display. "RTN","DGENRPT4",214,0) N PSSN,J,COUNT S (PSSN,J)="",COUNT=0 "RTN","DGENRPT4",215,0) F S J=$O(^TMP($J,"CNT4",J)) Q:J="" D "RTN","DGENRPT4",216,0) . F S PSSN=$O(^TMP($J,"CNT4",J,PSSN)) Q:PSSN="" S COUNT=COUNT+1 "RTN","DGENRPT4",217,0) W !,"TOTAL PATIENTS (UNIQUE SSNS) FOR THIS FACILITY: ",COUNT "RTN","DGENRPT4",218,0) Q "RTN","DGENRPT4",219,0) ; "RTN","DGENRPT4",220,0) EXIT ;Clean up upon exit of the routine. "RTN","DGENRPT4",221,0) D KVA^VADPT "RTN","DGENRPT4",222,0) K ^TMP($J,"BY4"),^TMP($J,"CNT4") "RTN","DGENRPT4",223,0) Q "RTN","DGMTO1") 0^4^B23209812 "RTN","DGMTO1",1,0) DGMTO1 ;ALB/CAW,AEG/EG - AGREED TO PAY DEDUCTIBLE PRINT (CON'T) ; 1/21/05 8:08am "RTN","DGMTO1",2,0) ;;5.3;Registration;**33,182,358,568,585**;Aug 13, 1993 "RTN","DGMTO1",3,0) ; "RTN","DGMTO1",4,0) START ; "RTN","DGMTO1",5,0) ; loop through cat Cs for active ones "RTN","DGMTO1",6,0) S (DGPAGE,DGSTOP)=0 "RTN","DGMTO1",7,0) F DGCAT=2,6 F DFN=0:0 S DFN=$O(^DPT("ACS",DGCAT,DFN)) Q:DFN'>0 D CATCLST "RTN","DGMTO1",8,0) D ACTIVE "RTN","DGMTO1",9,0) D CATCOUT "RTN","DGMTO1",10,0) K ^TMP("DGMTO",$J,"CNULL"),DFN "RTN","DGMTO1",11,0) D CLOSE^DGMTUTL "RTN","DGMTO1",12,0) Q "RTN","DGMTO1",13,0) ; "RTN","DGMTO1",14,0) CATCLST N DGDT,IEN,NODE0 "RTN","DGMTO1",15,0) S NODE0=$G(^DPT(DFN,0)) Q:(+$G(^(.35)))!($P(NODE0,U,14)'=DGCAT) "RTN","DGMTO1",16,0) F DGDT=0:0 S DGDT=$O(^DGMT(408.31,"AD",1,DFN,DGDT)) Q:'DGDT S IEN=$$MTIEN^DGMTU3(1,DFN,-DGDT) I IEN,(DGDT'DGTODAY) D "RTN","DGMTO1",17,0) .Q:DGCAT'[$P($G(^DGMT(408.31,+IEN,0)),U,3) "RTN","DGMTO1",18,0) .Q:$P($G(^DGMT(408.31,+IEN,0)),U,11)=1 "RTN","DGMTO1",19,0) .S ^TMP("DGMTO",$J,"CNULL",$P(NODE0,U,1),DFN)=";;"_$P(NODE0,U,1)_";;"_DGCAT_";;"_$$SR^DGMTAUD1($G(^DGMT(408.31,+IEN,0))) "RTN","DGMTO1",20,0) QTC Q "RTN","DGMTO1",21,0) ; "RTN","DGMTO1",22,0) ACTIVE ; "RTN","DGMTO1",23,0) N APWHEN,I,VETARRAY,PIEN,PNAME,RCNT,ACNT,DGARRAY,SDCNT,APT,CK1,CK3,PATNAM "RTN","DGMTO1",24,0) S ACNT=1,RCNT=0 "RTN","DGMTO1",25,0) S PNAME="" F S PNAME=$O(^TMP("DGMTO",$J,"CNULL",PNAME)) Q:PNAME="" D "RTN","DGMTO1",26,0) .S PIEN=0 F S PIEN=$O(^TMP("DGMTO",$J,"CNULL",PNAME,PIEN)) Q:'PIEN D "RTN","DGMTO1",27,0) ..S RCNT=RCNT+1,VETARRAY(ACNT)=$G(VETARRAY(ACNT))_PIEN_";" "RTN","DGMTO1",28,0) ..; Group DFNs by no more than twenty records "RTN","DGMTO1",29,0) ..I RCNT>19 S ACNT=ACNT+1,RCNT=0 "RTN","DGMTO1",30,0) ; "RTN","DGMTO1",31,0) ; Call SD API by array of Patient DFNs "RTN","DGMTO1",32,0) F I=1:1 Q:'$D(VETARRAY(I)) D "RTN","DGMTO1",33,0) .S DGARRAY("FLDS")="1",DGARRAY(4)=VETARRAY(I) "RTN","DGMTO1",34,0) .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) "RTN","DGMTO1",35,0) .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") "RTN","DGMTO1",36,0) .K DGARRAY,^TMP($J,"SDAMA301") "RTN","DGMTO1",37,0) ; "RTN","DGMTO1",38,0) ;if there is data hanging from the 101 subscript, "RTN","DGMTO1",39,0) ;then it is a valid appointment, otherwise "RTN","DGMTO1",40,0) ;it is an error eg 01/20/2005 "RTN","DGMTO1",41,0) ; Appointment Database was unavailable "RTN","DGMTO1",42,0) I $D(^TMP($J,"SDAMA",101))=1 K ^TMP("DGMTO",$J,"CNULL") S ^TMP("DGMTO",$J,"CNULL",101)="" Q "RTN","DGMTO1",43,0) ; "RTN","DGMTO1",44,0) ; Complete ^TMP entries for report "RTN","DGMTO1",45,0) N PATIEN,CLIEN,APPTDT,PATAPPT,APWHEN "RTN","DGMTO1",46,0) S PATNAM="" F S PATNAM=$O(^TMP("DGMTO",$J,"CNULL",PATNAM)) Q:PATNAM="" D "RTN","DGMTO1",47,0) .S PATIEN=0 F S PATIEN=$O(^TMP("DGMTO",$J,"CNULL",PATNAM,PATIEN)) Q:'PATIEN D "RTN","DGMTO1",48,0) ..; "RTN","DGMTO1",49,0) ..S CLIEN=0 F S CLIEN=$O(^TMP($J,"SDAMA",PATIEN,CLIEN)) Q:'CLIEN D "RTN","DGMTO1",50,0) ...S APPTDT=0 F S APPTDT=$O(^TMP($J,"SDAMA",PATIEN,CLIEN,APPTDT)) Q:'APPTDT D "RTN","DGMTO1",51,0) ....; Get list of appointments for vet "RTN","DGMTO1",52,0) ....S PATAPPT(APPTDT)=PATNAM "RTN","DGMTO1",53,0) ..; Update or Delete ^TMP for Report "RTN","DGMTO1",54,0) ..S APT=$O(^DPT(PATIEN,"DIS",(9999999-DGTODAY))),APWHEN="" "RTN","DGMTO1",55,0) ..I APT,(APT<(9999999-DGYRAGO)) S $P(APWHEN,U,1)="X" "RTN","DGMTO1",56,0) ..I +$G(^DPT(PATIEN,.105)) S $P(APWHEN,U,2)="X" "RTN","DGMTO1",57,0) ..I $O(PATAPPT(""),-1)>DT S $P(APWHEN,U,3)="X" "RTN","DGMTO1",58,0) ..K PATAPPT "RTN","DGMTO1",59,0) ..I APWHEN']"" D "RTN","DGMTO1",60,0) ...S CK1=$O(^DGPM("APRD",PATIEN,DGYRAGO)) I (+CK1)&(+CK10 S DGX=^(DFN) D Q:DGSTOP "RTN","DGMTO1",76,0) ..D PID^VADPT6 "RTN","DGMTO1",77,0) ..W !,$P(DGX,";;",2),?25,$S($P(DGX,";;",3)=2:"Pend Adj",1:"Cat. C"),?35,VA("PID"),?50,$P(DGX,";;",4),?59,$P($P(DGX,";;",1),U,1),?67,$P($P(DGX,";;",1),U,2),?75,$P($P(DGX,";;",1),U,3) "RTN","DGMTO1",78,0) ..D CHK "RTN","DGMTO1",79,0) K VA,VAPTYP,DGNAME "RTN","DGMTO1",80,0) Q "RTN","DGMTO1",81,0) ; "RTN","DGMTO1",82,0) HDR ; "RTN","DGMTO1",83,0) S DGPAGE=DGPAGE+1 "RTN","DGMTO1",84,0) W:$E(IOST,1,2)["C-" @IOF W "Active Patients Who Have Not Agreed To Pay Deductible",?70,"Page: "_DGPAGE "RTN","DGMTO1",85,0) W !,"Date Range: "_$$FDATE^DGMTUTL(DGYRAGO)_" to "_$$FDATE^DGMTUTL(DGTODAY) D NOW^%DTC W ?51,"Run Date: "_$E($$FTIME^DGMTUTL(%),1,18) "RTN","DGMTO1",86,0) W !,"" "RTN","DGMTO1",87,0) W !,?37,"PATIENT",?47,"MEANS TEST" "RTN","DGMTO1",88,0) W !,"PATIENT NAME",?25,"STATUS",?40,"ID",?49,"SOURCE",?58,"PAST",?64,"INHOUSE",?73,"FUTURE" "RTN","DGMTO1",89,0) S DGLINE="",$P(DGLINE,"=",IOM)="" "RTN","DGMTO1",90,0) W !,DGLINE "RTN","DGMTO1",91,0) Q "RTN","DGMTO1",92,0) CHK ;Check to pause on screen "RTN","DGMTO1",93,0) I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE S DGP=Y D:DGP HDR I 'DGP S DGSTOP=1 Q "RTN","DGMTO1",94,0) I $E(IOST,1,2)="P-",($Y+5)>IOSL,$O(^TMP("DGMTO",$J,DGNAME,DFN)) D HDR Q "RTN","DGMTO1",95,0) Q "RTN","DGMTO1",96,0) PAUSE ; "RTN","DGMTO1",97,0) W ! S DIR(0)="E" D ^DIR K DIR W ! "RTN","DGMTO1",98,0) Q "RTN","DGMTO1",99,0) LEGEND ;Legend at end of report "RTN","DGMTO1",100,0) W !!,"ACTIVE= Sched. Admissions, Dispositions, Pt. Movements, or Clinic Appts." "RTN","DGMTO1",101,0) W !!,?10,"INHOUSE = Current Inpatient" "RTN","DGMTO1",102,0) W !,?10,"PAST = ",$$FDATE^DGMTUTL(DGYRAGO)," to ",$$FDATE^DGMTUTL(DGTODAY) "RTN","DGMTO1",103,0) W !,?10,"FUTURE = After ",$$FDATE^DGMTUTL(DGTODAY) "RTN","DGMTO1",104,0) Q "RTN","DGPREBJ") 0^5^B16699456 "RTN","DGPREBJ",1,0) DGPREBJ ;Boise/WRL/ALB/SCK/EG-PreRegistration Night Task Job ; 1/20/05 1:08pm "RTN","DGPREBJ",2,0) ;;5.3;Registration;**109,581,568,585**;Aug 13, 1993 "RTN","DGPREBJ",3,0) Q "RTN","DGPREBJ",4,0) ; "RTN","DGPREBJ",5,0) EN ; Main entry point for the Pre-Registration Background Job. "RTN","DGPREBJ",6,0) ; Variables "RTN","DGPREBJ",7,0) ; DGPTOD - Current date "RTN","DGPREBJ",8,0) ; DGPNL - Message line count for mail message "RTN","DGPREBJ",9,0) ; DGPFNC - Job function "RTN","DGPREBJ",10,0) ; DGPNDAY - Number of days to keep entries in the call list "RTN","DGPREBJ",11,0) ; DGPTXT - Message array "RTN","DGPREBJ",12,0) ; DGPDT - Last date to keep entries in call list for, uses DGPNDAY "RTN","DGPREBJ",13,0) ; DGPN1-2 - Temporary Var's for $ORDER "RTN","DGPREBJ",14,0) ; DGPCLD - Count of call log entries purged "RTN","DGPREBJ",15,0) ; "RTN","DGPREBJ",16,0) N DGPTXT,DGPTOD,DGPFNC,DGPNL,DGPCLD,DGPDT,DGPN1,DGPN2,DGPNDAY "RTN","DGPREBJ",17,0) ; "RTN","DGPREBJ",18,0) S DGPTOD=$$DT^XLFDT() "RTN","DGPREBJ",19,0) ; "RTN","DGPREBJ",20,0) S DGPNL=1 "RTN","DGPREBJ",21,0) ; "RTN","DGPREBJ",22,0) S DGPFNC=$P($G(^DG(43,1,"DGPRE")),U,3) "RTN","DGPREBJ",23,0) I DGPFNC']""!(DGPFNC="N") D MES("MES1") G EXIT "RTN","DGPREBJ",24,0) ; "RTN","DGPREBJ",25,0) ; Get Appointment Information "RTN","DGPREBJ",26,0) D SDAMAPI^DGPREBJ1(0) "RTN","DGPREBJ",27,0) ; "RTN","DGPREBJ",28,0) ; Check for Appointment Database Availability "RTN","DGPREBJ",29,0) ;if there is no lower level data from the 101 subscript, then it is "RTN","DGPREBJ",30,0) ;an error, otherwise it could be a valid patient or clinic "RTN","DGPREBJ",31,0) ;eg 01/20/2005 "RTN","DGPREBJ",32,0) I $D(^TMP($J,"SDAMA301")) I $D(^TMP($J,"SDAMA301",101))=1 D SETTEXT^DGPREBJ("SDAMAPI - Appointment Database is Unavailable."),SETTEXT^DGPREBJ("Unable to update Call List."),SEND K ^TMP($J,"SDAMA301") Q "RTN","DGPREBJ",33,0) ; "RTN","DGPREBJ",34,0) ; DG/581 - delete certain entries in DGS(41.42 "RTN","DGPREBJ",35,0) N DGTDAY,DGIEN,DGOLD,DGZERO,DGDFN,DGAPDT,DGKFLAG,DGCLN,DGSTAT "RTN","DGPREBJ",36,0) D NOW^%DTC S DGTDAY=% "RTN","DGPREBJ",37,0) S (DGIEN,DGOLD)=0 "RTN","DGPREBJ",38,0) F S DGIEN=$O(^DGS(41.42,DGIEN)) Q:'DGIEN D "RTN","DGPREBJ",39,0) .S DGZERO=$G(^DGS(41.42,DGIEN,0)) Q:DGZERO="" "RTN","DGPREBJ",40,0) .S DGDFN=$P(DGZERO,U),DGAPDT=$P(DGZERO,U,8),DGCLN=$P(DGZERO,U,7) "RTN","DGPREBJ",41,0) .Q:('DGDFN)!('DGAPDT) "RTN","DGPREBJ",42,0) .S DGKFLAG=0 "RTN","DGPREBJ",43,0) .; delete if appt date less than NOW "RTN","DGPREBJ",44,0) .I DGAPDTDGPDT) D "RTN","DGPREBJ",67,0) . S DGPN2=0 F S DGPN2=$O(^DGS(41.43,"B",DGPN1,DGPN2)) Q:'DGPN2 D "RTN","DGPREBJ",68,0) .. S DGPCLD=DGPCLD+1 "RTN","DGPREBJ",69,0) .. S DIK="^DGS(41.43," "RTN","DGPREBJ",70,0) .. S DA=DGPN2 "RTN","DGPREBJ",71,0) .. D ^DIK K DIC "RTN","DGPREBJ",72,0) ; "RTN","DGPREBJ",73,0) D SETTEXT("Number of Entries Deleted From Call History: "_DGPCLD) "RTN","DGPREBJ",74,0) D SETTEXT(" ") "RTN","DGPREBJ",75,0) ; "RTN","DGPREBJ",76,0) EXIT ; "RTN","DGPREBJ",77,0) D SEND "RTN","DGPREBJ",78,0) Q "RTN","DGPREBJ",79,0) ; "RTN","DGPREBJ",80,0) SEND ; Send notification of actions taken to mailgroup "RTN","DGPREBJ",81,0) S XMY("G.DGPRE PRE-REG STAFF")="" "RTN","DGPREBJ",82,0) S XMDUZ=$S($G(DUZ)>0:DUZ,1:.5) "RTN","DGPREBJ",83,0) S XMTEXT="DGPTXT(" "RTN","DGPREBJ",84,0) S XMSUB="PRE-REGISTRATION NIGHTLY JOB REPORT" "RTN","DGPREBJ",85,0) D XMZ^XMA2 "RTN","DGPREBJ",86,0) D:XMZ>0 ^XMD "RTN","DGPREBJ",87,0) K XMY,XMDUZ,XMTEXT,XMSUB "RTN","DGPREBJ",88,0) Q "RTN","DGPREBJ",89,0) ; "RTN","DGPREBJ",90,0) SETTEXT(DGLINE) ; Add text line to message array "RTN","DGPREBJ",91,0) S DGPTXT(DGPNL)=DGLINE "RTN","DGPREBJ",92,0) S DGPNL=DGPNL+1 "RTN","DGPREBJ",93,0) Q "RTN","DGPREBJ",94,0) ; "RTN","DGPREBJ",95,0) PURGECP ; Purge called patients from the Pre-registration call list "RTN","DGPREBJ",96,0) ; Variables "RTN","DGPREBJ",97,0) ; DGPDEL - Counter of records deleted "RTN","DGPREBJ",98,0) ; "RTN","DGPREBJ",99,0) N DGPDEL "RTN","DGPREBJ",100,0) S DGPDEL=0 "RTN","DGPREBJ",101,0) ; "RTN","DGPREBJ",102,0) D PRGLST^DGPREP4(0,.DGPDEL) "RTN","DGPREBJ",103,0) ; "RTN","DGPREBJ",104,0) D SETTEXT(DGPDEL_" Called Patients Purged.") "RTN","DGPREBJ",105,0) D SETTEXT(" ") "RTN","DGPREBJ",106,0) Q "RTN","DGPREBJ",107,0) ; "RTN","DGPREBJ",108,0) KILLALL ; Clear all entries from the pre-registration call list. "RTN","DGPREBJ",109,0) ; Variables "RTN","DGPREBJ",110,0) ; DGPTOT - Counter if entries deleted "RTN","DGPREBJ",111,0) ; "RTN","DGPREBJ",112,0) N DGPTOT "RTN","DGPREBJ",113,0) S DGPTOT=0 "RTN","DGPREBJ",114,0) ; "RTN","DGPREBJ",115,0) D CLRLST^DGPREP4(0,.DGPTOT) "RTN","DGPREBJ",116,0) ; "RTN","DGPREBJ",117,0) D SETTEXT(DGPTOT_" Entries Deleted from the Call List.") "RTN","DGPREBJ",118,0) D SETTEXT(" ") "RTN","DGPREBJ",119,0) Q "RTN","DGPREBJ",120,0) ; "RTN","DGPREBJ",121,0) MES(TAG) ; Build message for missing parameters "RTN","DGPREBJ",122,0) N DGMES,I "RTN","DGPREBJ",123,0) ; "RTN","DGPREBJ",124,0) F I=1:1 S DGMES=$P($T(@TAG+I),";;",2,99) Q:DGMES="$$END" D SETTEXT(DGMES) "RTN","DGPREBJ",125,0) D SETTEXT(" ") "RTN","DGPREBJ",126,0) Q "RTN","DGPREBJ",127,0) ; "RTN","DGPREBJ",128,0) MES1 ; "RTN","DGPREBJ",129,0) ;;There is either no entry or a 'No Action' entry in the 'CALL LIST NIGHT JOB "RTN","DGPREBJ",130,0) ;;FUNCTION' field in the site parameter file. No action will be taken on the "RTN","DGPREBJ",131,0) ;;Call List. "RTN","DGPREBJ",132,0) ;;$$END "RTN","DGPREBJ1") 0^6^B40065727 "RTN","DGPREBJ1",1,0) DGPREBJ1 ;ALB/SCK/EG - PreRegistration Background job cont. ; 1/21/05 7:03am "RTN","DGPREBJ1",2,0) ;;5.3;Registration;**109,568,585**;Aug 13, 1993 "RTN","DGPREBJ1",3,0) Q "RTN","DGPREBJ1",4,0) ; "RTN","DGPREBJ1",5,0) EN ; Interactive entry (from option) "RTN","DGPREBJ1",6,0) ; Variables "RTN","DGPREBJ1",7,0) ; DGPTOD - Todays date from DT "RTN","DGPREBJ1",8,0) ; DGPNL - No. of lines in message array "RTN","DGPREBJ1",9,0) ; DGPTXT - Message array from ADDNEW procedure "RTN","DGPREBJ1",10,0) ; DGPP - Default date to look for appointments "RTN","DGPREBJ1",11,0) ; I1,X1-2 - Local variables for counters and date manipulation "RTN","DGPREBJ1",12,0) ; "RTN","DGPREBJ1",13,0) I '$D(^XUSEC("DGPRE SUPV",DUZ)) D G ENQ "RTN","DGPREBJ1",14,0) . W !!,"You do not have the DG PREREGISTRATION Key allocated, contact your MAS ADPAC." "RTN","DGPREBJ1",15,0) ; "RTN","DGPREBJ1",16,0) N DGPDT,DGPTOD,DGPNL,DGPTXT,DGPP,I1,X,X1,X2,Y "RTN","DGPREBJ1",17,0) S X1=$P($$NOW^XLFDT,"."),X2=$P($G(^DG(43,1,"DGPRE")),U,5) S:X2']"" X2=14 "RTN","DGPREBJ1",18,0) S DGPP=$$FMADD^XLFDT(X1,X2) "RTN","DGPREBJ1",19,0) S DIR("B")=$$FMTE^XLFDT(DGPP,1) "RTN","DGPREBJ1",20,0) S DIR(0)="DA^::EX",DIR("A")="Enter Appointment date to search: " "RTN","DGPREBJ1",21,0) D ^DIR K DIR "RTN","DGPREBJ1",22,0) G:$D(DIRUT) ENQ "RTN","DGPREBJ1",23,0) S DGPNL=0,DGPTOD=DT,DGPDT1=Y "RTN","DGPREBJ1",24,0) D WAIT^DICD "RTN","DGPREBJ1",25,0) D SDAMAPI(1,DGPDT1) "RTN","DGPREBJ1",26,0) D ADDNEW(1,DGPDT1) "RTN","DGPREBJ1",27,0) I $D(DGPTXT) W !!,"Results of updating the Call List with new entries",! "RTN","DGPREBJ1",28,0) S I1=0 F S I1=$O(DGPTXT(I1)) Q:'I1 W !,DGPTXT(I1) "RTN","DGPREBJ1",29,0) ENQ K DIRUT,DUOUT,DTOUT,DIROUT,DGARRAY,SCDNT,^TMP($J,"SDAMA301") "RTN","DGPREBJ1",30,0) Q "RTN","DGPREBJ1",31,0) ; "RTN","DGPREBJ1",32,0) ADDNEW(DGPREI,DGPDT1) ; Searches for appointments to add to the Call List "RTN","DGPREBJ1",33,0) ; Variables "RTN","DGPREBJ1",34,0) ; Input: "RTN","DGPREBJ1",35,0) ; DGPREI - Flag indicating how the procedure was called. "RTN","DGPREBJ1",36,0) ; 0 - called by background job "RTN","DGPREBJ1",37,0) ; 1 - called by option (interactive) "RTN","DGPREBJ1",38,0) ; DGPDT1 - Date to look for appointments, Required when "RTN","DGPREBJ1",39,0) ; DGPREI = 1 "RTN","DGPREBJ1",40,0) ; "RTN","DGPREBJ1",41,0) ; DGPDW - Day of the week "RTN","DGPREBJ1",42,0) ; DGPNDY - Number of days ahead to look for appt. "RTN","DGPREBJ1",43,0) ; DGPDT - Date to look for appt. ( DT + DGPNDY) "RTN","DGPREBJ1",44,0) ; DGPTOT - Counter, total records scanned "RTN","DGPREBJ1",45,0) ; DGPPT - Pointer to patient file, #2 "RTN","DGPREBJ1",46,0) ; DGPTDTH - Counter for patient alias's found "RTN","DGPREBJ1",47,0) ; DGPEXCL - Exclude flag "RTN","DGPREBJ1",48,0) ; DGPTCE - Counter of appts. excluded because of clinic "RTN","DGPREBJ1",49,0) ; DGPTPE - Counter of appts. excluded because of eligibility "RTN","DGPREBJ1",50,0) ; DGPINP - counter of appts. excluded because of inpatient "RTN","DGPREBJ1",51,0) ; DGPTNC - Counter of appts. excluded because next appt. is within "RTN","DGPREBJ1",52,0) ; DAYS BETWEEN CALLS entry in the MAS PARAMETER File "RTN","DGPREBJ1",53,0) ; DGPADD - Counter, entries added to call list "RTN","DGPREBJ1",54,0) ; DGPAPT - Date and time off appointment "RTN","DGPREBJ1",55,0) ; DGPPRDT - Date pre-registration audit file last updated for patient "RTN","DGPREBJ1",56,0) ; DGPNDTW - DAYS BETWEEN CALLS value "RTN","DGPREBJ1",57,0) ; DGPSV - Medical Service code "RTN","DGPREBJ1",58,0) ; DGPPN - Patients Name "RTN","DGPREBJ1",59,0) ; DGPPH - Patients Phone number "RTN","DGPREBJ1",60,0) ; DGPSN - Patients last four "RTN","DGPREBJ1",61,0) ; DGPN1-5 - Temporary variables for $O "RTN","DGPREBJ1",62,0) ; "RTN","DGPREBJ1",63,0) ; Check for Appointment Database Availability "RTN","DGPREBJ1",64,0) ;if there is no lower level data from the 101 subscript, then it "RTN","DGPREBJ1",65,0) ;really is a valid error, otherwise, it could be a patient "RTN","DGPREBJ1",66,0) ;or clinic eg 01/20/2005 "RTN","DGPREBJ1",67,0) I $D(^TMP($J,"SDAMA301")) I $D(^TMP($J,"SDAMA301",101))=1 D SETTEXT^DGPREBJ("SDAMAPI - Appointment Database is Unavailable."),SETTEXT^DGPREBJ("Unable to update Call List.") Q "RTN","DGPREBJ1",68,0) ; "RTN","DGPREBJ1",69,0) N DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,DGPUPD,DGPN1,DGPAPT "RTN","DGPREBJ1",70,0) N DGPPH,DGPDW,DGPPT,DGPPRDT,DGPNDTW,DGPN5,DGPEXCL,CKAPDT "RTN","DGPREBJ1",71,0) S (DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,DGPUPD)=0 "RTN","DGPREBJ1",72,0) S DGPN1=0 F S DGPN1=$O(^TMP($J,"SDAMA301",DGPN1)) Q:'DGPN1 D "RTN","DGPREBJ1",73,0) .S DGPPT=0 F S DGPPT=$O(^TMP($J,"SDAMA301",DGPN1,DGPPT)) Q:'DGPPT D "RTN","DGPREBJ1",74,0) ..S CKAPDT=+$O(^TMP($J,"SDAMA301",DGPN1,DGPPT,DGPDT1)) "RTN","DGPREBJ1",75,0) ..Q:('CKAPDT!(CKAPDT>$$FMADD^XLFDT(DGPDT1,1))) "RTN","DGPREBJ1",76,0) ..S DGPTOT=DGPTOT+1 "RTN","DGPREBJ1",77,0) ..I $P($G(^DPT(DGPPT,.35)),U)]"" S DGPTDTH=DGPTDTH+1 Q "RTN","DGPREBJ1",78,0) ..; *** Check for clinic exclusions in MAS PARAMETER File "RTN","DGPREBJ1",79,0) ..S (DGPN5,DGPEXCL)=0 "RTN","DGPREBJ1",80,0) ..F S DGPN5=$O(^DG(43,1,"DGPREC",DGPN5)) Q:'DGPN5!(DGPEXCL) D "RTN","DGPREBJ1",81,0) ...S:$P(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1 DGPEXCL=1 "RTN","DGPREBJ1",82,0) ..I DGPEXCL S DGPTCE=DGPTCE+1 Q "RTN","DGPREBJ1",83,0) ..; *** Check for eligibility exclusions inthe MAS PARAMETER File "RTN","DGPREBJ1",84,0) ..N DGPAELG S (DGPN5,DGPEXCL)=0 "RTN","DGPREBJ1",85,0) ..F S DGPN5=$O(^DG(43,1,"DGPREE",DGPN5)) Q:'DGPN5!(DGPEXCL) D "RTN","DGPREBJ1",86,0) ...S DGPAELG=$P($G(^DPT(DGPPT,.36)),U) "RTN","DGPREBJ1",87,0) ...S:$P(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG DGPEXCL=1 "RTN","DGPREBJ1",88,0) ..I DGPEXCL S DGPTPE=DGPTPE+1 Q "RTN","DGPREBJ1",89,0) ..; *** Check for inpatient status "RTN","DGPREBJ1",90,0) ..K DFN S DFN=DGPPT D INP^VADPT "RTN","DGPREBJ1",91,0) ..I $G(VAIN(1))]"" S DGPINP=DGPINP+1 Q "RTN","DGPREBJ1",92,0) ..; *** Check for last update in Pre-Registration Audit file "RTN","DGPREBJ1",93,0) ..S DGPPRDT=DGPTOD+.9999,DGPPRDT=$O(^DGS(41.41,"ADC",DGPPT,DGPPRDT),-1) "RTN","DGPREBJ1",94,0) ..S DGPNDTW=$P($G(^DG(43,1,"DGPRE")),U,2) "RTN","DGPREBJ1",95,0) ..I DGPPRDT]""&(DGPNDTW]"") I $$FMDIFF^XLFDT(DGPDT,DGPPRDT,1)32,J'=",",J'="-",J'=".",J'="'" S I1=1 "RTN","DGRPC",29,0) I I1 S X=1 D COMB "RTN","DGRPC",30,0) D NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",31,0) 2 S I1=0 F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I!(I1) I $P(^(I,0),"^",1)'?1A.E S I1=1 "RTN","DGRPC",32,0) I I1 S X=2 D COMB "RTN","DGRPC",33,0) D NEXT I +DGLST>7!('DGLST) G @DGLST "RTN","DGRPC",34,0) 3 ; "RTN","DGRPC",35,0) 4 ; "RTN","DGRPC",36,0) 5 ; "RTN","DGRPC",37,0) 6 ; "RTN","DGRPC",38,0) 7 F I=2,3,5,8,9 I $P(DGP(0),"^",I)="" S X=$S(I=2:3,I=3:4,I=5:5,I=8:6,1:7) D COMB:DGCHK[(","_X_",") "RTN","DGRPC",39,0) S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST "RTN","DGRPC",40,0) 8 S I1=0,DGD=$G(^DPT(DFN,.11)) F I=1,4,5,6,7 Q:I1 I $P(DGD,"^",I)="" S I1=1 "RTN","DGRPC",41,0) I I1 S X=8 D COMB "RTN","DGRPC",42,0) D NEXT I +DGLST'=9 G @DGLST "RTN","DGRPC",43,0) 9 I DGP("VET")="" S X=9,DGNCK=1 D COMB "RTN","DGRPC",44,0) D NEXT I +DGLST'=10 G @DGLST "RTN","DGRPC",45,0) 10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB "RTN","DGRPC",46,0) D NEXT I +DGLST'=11 G @DGLST "RTN","DGRPC",47,0) 11 I 'DGVT,DGSC S X=11 D COMB "RTN","DGRPC",48,0) D NEXT I +DGLST'=12 G @DGLST "RTN","DGRPC",49,0) 12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB "RTN","DGRPC",50,0) D NEXT I +DGLST'=13 G @DGLST "RTN","DGRPC",51,0) 13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB "RTN","DGRPC",52,0) D NEXT I +DGLST'=14 G @DGLST "RTN","DGRPC",53,0) 14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB "RTN","DGRPC",54,0) ; "RTN","DGRPC",55,0) ;Check Patient Eligibilities multiple if Primary Elig Code defined "RTN","DGRPC",56,0) I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301 "RTN","DGRPC",57,0) ; "RTN","DGRPC",58,0) D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",59,0) 15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB "RTN","DGRPC",60,0) D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",61,0) 16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB "RTN","DGRPC",62,0) D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",63,0) 17 K DGDATE,DGTIME "RTN","DGRPC",64,0) N SDARRAY,SDCLIEN,SDDATE "RTN","DGRPC",65,0) S I1=0,DGD=DT "RTN","DGRPC",66,0) S SDARRAY("FLDS")=3 "RTN","DGRPC",67,0) S SDARRAY(4)=DFN "RTN","DGRPC",68,0) I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D "RTN","DGRPC",69,0) .;if there is data hanging from the 101 subscript, "RTN","DGRPC",70,0) .;then this is a valid appointment "RTN","DGRPC",71,0) .;otherwise it is an error eg 01/21/2005 "RTN","DGRPC",72,0) .I $D(^TMP($J,"SDAMA301",101))=1 Q "RTN","DGRPC",73,0) .S SDCLIEN=0 "RTN","DGRPC",74,0) .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(I1) D "RTN","DGRPC",75,0) ..S SDDATE=0 "RTN","DGRPC",76,0) ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(I1) D "RTN","DGRPC",77,0) ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";") "RTN","DGRPC",78,0) ...I X=""!(X="I") S I1=1 "RTN","DGRPC",79,0) K ^TMP($J,"SDAMA301") "RTN","DGRPC",80,0) I I1 S X=17 D COMB "RTN","DGRPC",81,0) ; "RTN","DGRPC",82,0) END ; end of routine...find next check to execute (or goto end) "RTN","DGRPC",83,0) S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST "RTN","DGRPC",84,0) ; "RTN","DGRPC",85,0) COMB ;record inconsistency "RTN","DGRPC",86,0) S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q "RTN","DGRPC",87,0) Q "RTN","DGRPC",88,0) ; "RTN","DGRPC",89,0) NEXT ; find the next consistency check to check (goto end if can't process further) "RTN","DGRPC",90,0) S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q "RTN","DGRPC",91,0) I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35," G NEXT "RTN","DGRPC",92,0) S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,+DGLST<79:2,1:3) "RTN","DGRPC",93,0) Q "RTN","DGRPC",94,0) ; "RTN","DGRPC",95,0) PAT ;check inconsistencies for a selected patient "RTN","DGRPC",96,0) D ON G KVAR^DGRPCE:DGER W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Check consistency for which PATIENT: " D ^DIC K DIC G KVAR^DGRPCE:Y'>0 S DFN=+Y,DGEDCN=1 D DGRPC G PAT "RTN","DGRPC",97,0) ; "RTN","DGRPC",98,0) START ;record start time for checker "RTN","DGRPC",99,0) S DGSTART=$H Q "RTN","DGRPC",100,0) ; "RTN","DGRPC",101,0) TIME ;record end time for checker "RTN","DGRPC",102,0) Q:'$D(DGSTART)#2 S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2) "RTN","DGRPC",103,0) I +DGSTART=+DGEND S DGTIME=X1-X "RTN","DGRPC",104,0) E S DGTIME=(5184000-X)+X1 "RTN","DGRPC",105,0) I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ "RTN","DGRPC",106,0) W !!,"===> ",$S(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$S(DGCT=1:"y",1:"ies")," ",$S('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$S(DGTIME=1:"",1:"s"),"..." H 1 "RTN","DGRPC",107,0) TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q "RTN","DGRPC",108,0) ; "RTN","DGRPC",109,0) ON ;check if checker is on "RTN","DGRPC",110,0) S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1 "RTN","DGRPC",111,0) S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q "RTN","DGRPD") 0^9^B62383955 "RTN","DGRPD",1,0) DGRPD ;ALB/MRL/MLR/JAN/LBD/EG-PATIENT INQUIRY (NEW) ; 1/20/05 1:15pm "RTN","DGRPD",2,0) ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585**;Aug 13, 1993 "RTN","DGRPD",3,0) ; *286* Newing variables X,Y in OKLINE subroutine "RTN","DGRPD",4,0) ; *358* If a patient is on a domiciliary ward, don't display MEANS "RTN","DGRPD",5,0) ; TEST required/Medication Copayment Exemption messages "RTN","DGRPD",6,0) ; *436* If an inpatient is not on a domiciliary ward, don't display "RTN","DGRPD",7,0) ; Medication Copayment Exemption message "RTN","DGRPD",8,0) ; *545* Add death information near the remarks field "RTN","DGRPD",9,0) ; "RTN","DGRPD",10,0) SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL "RTN","DGRPD",11,0) ; "RTN","DGRPD",12,0) EN ;call to display patient inquiry - input DFN "RTN","DGRPD",13,0) ;MPI/PD CHANGE "RTN","DGRPD",14,0) S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI")) "RTN","DGRPD",15,0) S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED") "RTN","DGRPD",16,0) I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^") "RTN","DGRPD",17,0) ;END MPI/PD CHANGE "RTN","DGRPD",18,0) K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361,.141 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPD",19,0) S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'50) !?10 W:'(I#2) ?51 W DGA(I) "RTN","DGRPD",22,0) S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?2,"County: ",DGCC "RTN","DGRPD",23,0) S X="NOT APPLICABLE" I DGTMPAD 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","DGRPD",24,0) W ?42,"From/To: ",X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPAD "RTN","DGRPD",25,0) W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU) "RTN","DGRPD",26,0) W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN)) "RTN","DGRPD",27,0) D CA "RTN","DGRPD",28,0) I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED") "RTN","DGRPD",29,0) I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") "RTN","DGRPD",30,0) I 'DGABBRV W ! D "RTN","DGRPD",31,0) .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF "RTN","DGRPD",32,0) .K ^UTILITY($J,"W") "RTN","DGRPD",33,0) .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D "RTN","DGRPD",34,0) ..S VAL=+$G(^DPT(DFN,.02,PTR,0)) "RTN","DGRPD",35,0) ..Q:$$INACTIVE^DGUTL4(VAL,1) "RTN","DGRPD",36,0) ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", " "RTN","DGRPD",37,0) ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP "RTN","DGRPD",38,0) .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED" "RTN","DGRPD",39,0) .K ^UTILITY($J,"W") "RTN","DGRPD",40,0) .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D "RTN","DGRPD",41,0) ..S VAL=+$G(^DPT(DFN,.06,PTR,0)) "RTN","DGRPD",42,0) ..Q:$$INACTIVE^DGUTL4(VAL,2) "RTN","DGRPD",43,0) ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", " "RTN","DGRPD",44,0) ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP "RTN","DGRPD",45,0) .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED" "RTN","DGRPD",46,0) .K ^UTILITY($J,"W") "RTN","DGRPD",47,0) .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0) "RTN","DGRPD",48,0) .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0)) "RTN","DGRPD",49,0) I '$$OKLINE(16) G Q "RTN","DGRPD",50,0) S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !!,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU) "RTN","DGRPD",51,0) W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X "RTN","DGRPD",52,0) ; "RTN","DGRPD",53,0) ;display the catastrophic disability review date if there is one "RTN","DGRPD",54,0) D CATDIS "RTN","DGRPD",55,0) ; "RTN","DGRPD",56,0) I $G(DGPRFLG)=1 G Q:'$$OKLINE(19) D "RTN","DGRPD",57,0) . N DGPDT,DGPTM "RTN","DGRPD",58,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",59,0) . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1) "RTN","DGRPD",60,0) . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE") "RTN","DGRPD",61,0) . S DGPTM=$$PCTEAM^DGSDUTL(DFN) "RTN","DGRPD",62,0) . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2) "RTN","DGRPD",63,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",64,0) ; Check if patient is an inpatient and on a DOM ward "RTN","DGRPD",65,0) ; If inpatient is on a DOM ward, don't display MT or CP messages "RTN","DGRPD",66,0) ; If inpatient is NOT on a DOM ward, don't display CP message "RTN","DGRPD",67,0) N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR "RTN","DGRPD",68,0) G Q:'$$OKLINE(14) "RTN","DGRPD",69,0) D DOM^DGMTR "RTN","DGRPD",70,0) I '$G(DGDOM) D "RTN","DGRPD",71,0) .D DIS^DGMTU(DFN) "RTN","DGRPD",72,0) .D IN5^VADPT "RTN","DGRPD",73,0) .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1) "RTN","DGRPD",74,0) ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W ! "RTN","DGRPD",75,0) D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518) "RTN","DGRPD",76,0) S VAIP("L")="" "RTN","DGRPD",77,0) I $$OKLINE(14) D INP "RTN","DGRPD",78,0) I '$G(DGRPOUT),($$OKLINE(17)) D SA "RTN","DGRPD",79,0) ;MPI/PD CHANGE "RTN","DGRPD",80,0) Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q "RTN","DGRPD",81,0) CA ;Confidential Address "RTN","DGRPD",82,0) W !!?1,"Confidential Address: ",?44,"Confidential Address Categories:" "RTN","DGRPD",83,0) N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR "RTN","DGRPD",84,0) S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8) "RTN","DGRPD",85,0) I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND43) !?9 W:'(I#2) ?44 W DGA(I) "RTN","DGRPD",101,0) W !?1,"From/To: ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED") "RTN","DGRPD",102,0) Q "RTN","DGRPD",103,0) HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP "RTN","DGRPD",104,0) ;MPI/PD CHANGE "RTN","DGRPD",105,0) W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q "RTN","DGRPD",106,0) ;END MPI/PD CHANGE "RTN","DGRPD",107,0) INP S VAIP("D")="L" D INP^DGPMV10 "RTN","DGRPD",108,0) S DGPMT=0 "RTN","DGRPD",109,0) D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q "RTN","DGRPD",110,0) SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE(17) SAA Q:$G(DGRPOUT) "RTN","DGRPD",111,0) Q "RTN","DGRPD",112,0) SAA ;Scheduled Admit Data "RTN","DGRPD",113,0) W !!?14,"Scheduled Admit" "RTN","DGRPD",114,0) W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U) "RTN","DGRPD",115,0) W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U) "RTN","DGRPD",116,0) W " on "_$$FMTE^XLFDT(L,"5DZ") "RTN","DGRPD",117,0) Q ;SAA "RTN","DGRPD",118,0) ; "RTN","DGRPD",119,0) CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"") "RTN","DGRPD",120,0) ; "RTN","DGRPD",121,0) FA G:'$$OKLINE(20) RMK "RTN","DGRPD",122,0) ; "RTN","DGRPD",123,0) N DGARRAY,SDCNT "RTN","DGRPD",124,0) S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P" "RTN","DGRPD",125,0) S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: " "RTN","DGRPD",126,0) ;if there is lower subscripts hanging from the 101 node, "RTN","DGRPD",127,0) ;then it is a valid appointment, otherwise it is "RTN","DGRPD",128,0) ;an error eg 01/20/2005 "RTN","DGRPD",129,0) I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK "RTN","DGRPD",130,0) I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK "RTN","DGRPD",131,0) ; "RTN","DGRPD",132,0) W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "=" "RTN","DGRPD",133,0) F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5 "RTN","DGRPD",134,0) .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";") "RTN","DGRPD",135,0) .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D "RTN","DGRPD",136,0) ..D COV "RTN","DGRPD",137,0) ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z") "RTN","DGRPD",138,0) ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2) "RTN","DGRPD",139,0) ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV "RTN","DGRPD",140,0) ..Q "RTN","DGRPD",141,0) I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments." "RTN","DGRPD",142,0) RMK I '$G(DGRPOUT),($$OKLINE(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) "RTN","DGRPD",143,0) D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO") "RTN","DGRPD",144,0) W !! "RTN","DGRPD",145,0) W "Date of Death Information" "RTN","DGRPD",146,0) W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E")) "RTN","DGRPD",147,0) W !,?5,"Date of Death Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E")) "RTN","DGRPD",148,0) W !,?5,"Date of Death Last Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E")) "RTN","DGRPD",149,0) W !,?5,"Date of Death Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),! "RTN","DGRPD",150,0) K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky "RTN","DGRPD",151,0) Q "RTN","DGRPD",152,0) COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"") "RTN","DGRPD",153,0) S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q "RTN","DGRPD",154,0) Q "RTN","DGRPD",155,0) ; "RTN","DGRPD",156,0) OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME "RTN","DGRPD",157,0) Q "RTN","DGRPD",158,0) OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE "RTN","DGRPD",159,0) ; "RTN","DGRPD",160,0) ;IN: DGLINE --MAX LINE COUNT W/O PAUSE "RTN","DGRPD",161,0) ;OUT: DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW "RTN","DGRPD",162,0) ; DGRPOUT[SET] -- 1 IF " "RTN","DGRPD",163,0) N X,Y ;**286** MLR 09/25/00 Newing X & Y variables prior to ^DIR "RTN","DGRPD",164,0) I $G(IOST)["P-" Q DGLINE ; if printer, quit "RTN","DGRPD",165,0) I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0 "RTN","DGRPD",166,0) Q DGLINE "RTN","DGRPD",167,0) ; "RTN","DGRPD",168,0) CATDIS ; "RTN","DGRPD",169,0) ;displays catastrophic disabity review date if there is one "RTN","DGRPD",170,0) N DGCDIS "RTN","DGRPD",171,0) I $$GET^DGENCDA(DFN,.DGCDIS) D "RTN","DGRPD",172,0) .Q:'DGCDIS("REVDTE") "RTN","DGRPD",173,0) .W !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1) "RTN","DGRPD",174,0) Q "RTN","DGRPD",175,0) ; "RTN","VAFCCCAP") 0^10^B23708832 "RTN","VAFCCCAP",1,0) VAFCCCAP ;ALB/CMM/PKE/PHH/EG OUTPATIENT CAPTURE TEST ; 1/20/05 1:17pm "RTN","VAFCCCAP",2,0) ;;5.3;Registration;**91,179,553,582,568,585**;Jun 06, 1996 "RTN","VAFCCCAP",3,0) ; "RTN","VAFCCCAP",4,0) ; "RTN","VAFCCCAP",5,0) CAP ;Only fire if check-in,check-out, add/edit add, add/edit change "RTN","VAFCCCAP",6,0) I ($G(SDAMEVT)<4)!($G(SDAMEVT)>7) Q "RTN","VAFCCCAP",7,0) ;quit if no change "RTN","VAFCCCAP",8,0) I +$G(SDATA("BEFORE","STATUS"))=3,+$G(SDATA("AFTER","STATUS"))=3 "RTN","VAFCCCAP",9,0) IF I $P($G(SDATA("AFTER","STATUS")),"^",3)'="ACTION REQ/CHECKED IN" "RTN","VAFCCCAP",10,0) IF I $P($G(SDATA("BEFORE","STATUS")),"^",3)'="NO ACTION TAKEN/TODAY" Q "RTN","VAFCCCAP",11,0) ;check to see if sending is on or off "RTN","VAFCCCAP",12,0) I '$P($$SEND^VAFHUTL(),"^",2) Q "RTN","VAFCCCAP",13,0) ;check if protocol disabled or no clients "RTN","VAFCCCAP",14,0) I $$PROTOCHK("VAFC ADT-A08-SDAM SERVER") Q "RTN","VAFCCCAP",15,0) ;Queue to run NOW, returns control back to outpatient event driver "RTN","VAFCCCAP",16,0) S ZTRTN="EN^VAFCCCAP",ZTDESC="PIMS Outpatient HL7 v2.3 Capture" "RTN","VAFCCCAP",17,0) S ZTSAVE("SDHDL")="",ZTSAVE("SDAMEVT")="",ZTSAVE("SDATA")="",ZTSAVE("^TMP(""SDEVT"",$J,")="",ZTIO="",ZTDTH=$H "RTN","VAFCCCAP",18,0) D ^%ZTLOAD "RTN","VAFCCCAP",19,0) ;W !?3,$G(ZTSK) "RTN","VAFCCCAP",20,0) Q "RTN","VAFCCCAP",21,0) ; "RTN","VAFCCCAP",22,0) EN ; "RTN","VAFCCCAP",23,0) N DFN,HLD,EVDT,CHK,ERR,SEND,NEW,EVENT,HOSP,THLD,PTR,REM,HPTR "RTN","VAFCCCAP",24,0) ; "RTN","VAFCCCAP",25,0) ;Appointments "RTN","VAFCCCAP",26,0) ; "RTN","VAFCCCAP",27,0) I SDAMEVT=4!(SDAMEVT=5) D "RTN","VAFCCCAP",28,0) .S DFN=$P(SDATA,"^",2),EVDT=$P(SDATA,"^",3),PTR=$$GETPTR^VAFHCUTL(1),PTR=PTR_";SCE(",(CHK,UP,REM)="" "RTN","VAFCCCAP",29,0) .I SDAMEVT=4 S PTR=DFN_";DPT(" ;check-in or unscheduled visit check-in "RTN","VAFCCCAP",30,0) .;Need to check if deleting check-out "RTN","VAFCCCAP",31,0) .;if deleting check-out and no pivot file entry exists don't send "RTN","VAFCCCAP",32,0) .I +$G(SDATA("AFTER","STATUS"))=3&(+$G(SDATA("BEFORE","STATUS"))=2) S CHK=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,PTR),PTR=$$UPPTR(DFN,EVDT) S:PTR="@" REM=1 S:+CHK>0 UP=$$UPDATE^VAFHUTL(+CHK,EVDT,PTR,REM) S:+CHK<0!(+UP<0) SEND="N" "RTN","VAFCCCAP",33,0) .;set send to N if deleting and not in pivot file "RTN","VAFCCCAP",34,0) .I '$D(SEND) D "RTN","VAFCCCAP",35,0) ..S HLD=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,PTR) "RTN","VAFCCCAP",36,0) ..I +HLD=-1 S HPTR=DFN_";DPT(",HLD=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,HPTR) I +HLD'=-1 S UP=$$UPDATE^VAFHUTL(+HLD,EVDT,PTR,"") "RTN","VAFCCCAP",37,0) ..I +HLD=-1 S HLD=$$PIVNW^VAFHPIVT(DFN,EVDT,2,PTR) "RTN","VAFCCCAP",38,0) ..;S EVENT=$P(HLD,":"),ERR=$$OA08^VAFHCA08(DFN,EVENT,EVDT,PTR,"2,3,4,5,6,7,8,9,11,12,13,14,16,19","2,3,4,5,6,7,8,9,10,11,12,13,14,15","A","A") "RTN","VAFCCCAP",39,0) ..;set up call to vafcmsg for out-patient "RTN","VAFCCCAP",40,0) ..D SETUP "RTN","VAFCCCAP",41,0) ; "RTN","VAFCCCAP",42,0) ;Stop codes, Add/Edits "RTN","VAFCCCAP",43,0) I SDAMEVT=6!(SDAMEVT=7) D "RTN","VAFCCCAP",44,0) .N HLD,STOP,THLD,REMOVE,UP "RTN","VAFCCCAP",45,0) .S HLD="",STOP="N",ERR="" "RTN","VAFCCCAP",46,0) .F K EVENT S REMOVE="N",HLD=$O(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD)) Q:HLD=""!(STOP="Y") D "RTN","VAFCCCAP",47,0) ..I ^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER")'=""&($P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER"),"^",6)'="") S STOP="Y" Q "RTN","VAFCCCAP",48,0) ..;If STOP="Y" stop code was not stand alone "RTN","VAFCCCAP",49,0) ..;If STOP="N" stop code is stand alone "RTN","VAFCCCAP",50,0) ..I ^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER")="" D "RTN","VAFCCCAP",51,0) ...S REMOVE="Y",DFN=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"BEFORE"),"^",2),EVDT=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"BEFORE"),"^"),PTR=HLD_";SCE(" "RTN","VAFCCCAP",52,0) ...S EVENT=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,PTR) "RTN","VAFCCCAP",53,0) ..I ^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER")'="" D "RTN","VAFCCCAP",54,0) ...S DFN=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER"),"^",2),EVDT=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER"),"^"),PTR=HLD_";SCE(" "RTN","VAFCCCAP",55,0) ..I '$D(EVENT) S THLD=$$PIVNW^VAFHPIVT(DFN,EVDT,2,PTR),EVENT=$P(THLD,":") "RTN","VAFCCCAP",56,0) ..I REMOVE="Y" S PTR="@",UP=$$UPDATE^VAFHUTL(+EVENT,EVDT,PTR,1) "RTN","VAFCCCAP",57,0) ..;I +EVENT>0 S ERR=$$OA08^VAFHCA08(DFN,EVENT,EVDT,PTR,"2,3,4,5,6,7,8,9,11,12,13,14,16,19","2,3,4,5,6,7,8,9,10,11,12,13,14,15","A","A") "RTN","VAFCCCAP",58,0) ..;set up call to vafcmsg for out-patient "RTN","VAFCCCAP",59,0) ..I +EVENT>0 D SETUP "RTN","VAFCCCAP",60,0) ; "RTN","VAFCCCAP",61,0) EXIT ; "RTN","VAFCCCAP",62,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","VAFCCCAP",63,0) I +ERR<0 D ERROR(ERR,DFN) "RTN","VAFCCCAP",64,0) D KILL^HLTRANS "RTN","VAFCCCAP",65,0) Q "RTN","VAFCCCAP",66,0) ; "RTN","VAFCCCAP",67,0) ERROR(PNUM,DFN) ; "RTN","VAFCCCAP",68,0) ;Error message unable to generate A08 Message "RTN","VAFCCCAP",69,0) N GBL S GBL="^TMP($J,""ERR"")" "RTN","VAFCCCAP",70,0) I +PNUM<0 S @GBL@(0)="ERROR",@GBL@(1)=$P(PNUM,"^",2)_", unable to generate A08 Message" D EBULL^VAFHUTL2(DFN,"","",$P(GBL,")")_",") "RTN","VAFCCCAP",71,0) Q "RTN","VAFCCCAP",72,0) ; "RTN","VAFCCCAP",73,0) UPPTR(DFN,ADATE) ; "RTN","VAFCCCAP",74,0) ;Have deleted checkout, update variable pointer "RTN","VAFCCCAP",75,0) N PTR S PTR="@" "RTN","VAFCCCAP",76,0) N DGARRAY,DGCOUNT,SDDATE "RTN","VAFCCCAP",77,0) S DGARRAY(4)=DFN,DGARRAY(1)=ADATE_";"_ADATE,DGARRAY("FLDS")=3,DGARRAY("SORT")="P" "RTN","VAFCCCAP",78,0) S DGCOUNT=$$SDAPI^SDAMA301(.DGARRAY) "RTN","VAFCCCAP",79,0) ; "RTN","VAFCCCAP",80,0) ;if there is data hanging from the 101 or "RTN","VAFCCCAP",81,0) ;116 subscript, then it is a valid appointment "RTN","VAFCCCAP",82,0) ;otherwise it is an error eg 01/20/2005 "RTN","VAFCCCAP",83,0) I DGCOUNT<0,$D(^TMP($J,"SDAMA301",101))=1 Q PTR "RTN","VAFCCCAP",84,0) I DGCOUNT<0,$D(^TMP($J,"SDAMA301",116))=1 Q PTR "RTN","VAFCCCAP",85,0) I DGCOUNT>0 D "RTN","VAFCCCAP",86,0) .S SDDATE=0 "RTN","VAFCCCAP",87,0) .F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDDATE)) Q:'SDDATE D "RTN","VAFCCCAP",88,0) ..I SDDATE=ADATE S PTR=DFN_";DPT(" "RTN","VAFCCCAP",89,0) I DGCOUNT'=0 K ^TMP($J,"SDAMA301") "RTN","VAFCCCAP",90,0) Q PTR "RTN","VAFCCCAP",91,0) ; "RTN","VAFCCCAP",92,0) SETUP ; "RTN","VAFCCCAP",93,0) N PIVOTPTR "RTN","VAFCCCAP",94,0) S EVENT=$P(HLD,":") "RTN","VAFCCCAP",95,0) S EVNTINFO="^TMP(""VAFCMSG"",""EVNTINFO"","_$J_")" "RTN","VAFCCCAP",96,0) K @EVNTINFO "RTN","VAFCCCAP",97,0) S PIVOTPTR=+$O(^VAT(391.71,"D",EVENT,0)) "RTN","VAFCCCAP",98,0) I ('PIVOTPTR) S ERR="-1^Unable to create entry in ADT/HL7 PIVOT FILE" Q "RTN","VAFCCCAP",99,0) S @EVNTINFO@("PIVOT")=PIVOTPTR "RTN","VAFCCCAP",100,0) S @EVNTINFO@("SERVER PROTOCOL")="VAFC ADT-A08-SDAM SERVER" "RTN","VAFCCCAP",101,0) S @EVNTINFO@("VAR-PTR")=PTR "RTN","VAFCCCAP",102,0) S @EVNTINFO@("EVENT-NUM")=EVENT "RTN","VAFCCCAP",103,0) S ERR=$$BCSTADT^VAFCMSG0(DFN,"A08",EVDT,EVNTINFO) "RTN","VAFCCCAP",104,0) K @EVNTINFO "RTN","VAFCCCAP",105,0) Q "RTN","VAFCCCAP",106,0) PROTOCHK(SPROTO) ; "RTN","VAFCCCAP",107,0) ; input server protocol "RTN","VAFCCCAP",108,0) ;output 1 if disabled or has no clients "RTN","VAFCCCAP",109,0) N HL "RTN","VAFCCCAP",110,0) D INIT^HLFNC2(SPROTO,.HL,1) "RTN","VAFCCCAP",111,0) K HLQ,HLECH,HLFS "RTN","VAFCCCAP",112,0) Q $D(HL)#2 "RTN","VAFCCOPT") 0^11^B12640858 "RTN","VAFCCOPT",1,0) VAFCCOPT ;ALB/CM/PHH/EG OUTPATIENT APPT (HL7 MESS) NIGHT JOB ; 1/20/05 1:19pm "RTN","VAFCCOPT",2,0) ;;5.3;Registration;**91,298,568,585**;Jun 06, 1996 "RTN","VAFCCOPT",3,0) ;hl7v1.6 "RTN","VAFCCOPT",4,0) ;This routine will loop through the Hospital Location file "S" node "RTN","VAFCCOPT",5,0) ;and generate an HL7-v2.3 A08 message for all appointments for today "RTN","VAFCCOPT",6,0) ;that have a status of "No action taken" or "Future" "RTN","VAFCCOPT",7,0) ;the HL7 message is not batch. "RTN","VAFCCOPT",8,0) ; "RTN","VAFCCOPT",9,0) ;07/07/00 ACS - Added sequence 39 (facility+suffix) to the outpatient "RTN","VAFCCOPT",10,0) ;string of fields "RTN","VAFCCOPT",11,0) ; "RTN","VAFCCOPT",12,0) ;Check to see if sending v2.3 is on or off "RTN","VAFCCOPT",13,0) EN I '$P($$SEND^VAFHUTL(),"^",2) Q "RTN","VAFCCOPT",14,0) ; "RTN","VAFCCOPT",15,0) S ERRB="^TMP($J,""ADT-ERR""," "RTN","VAFCCOPT",16,0) ; "RTN","VAFCCOPT",17,0) N STAT,X1,X2 "RTN","VAFCCOPT",18,0) ;This job should be set to run after midnight daily. "RTN","VAFCCOPT",19,0) D NOW^%DTC S START=X "RTN","VAFCCOPT",20,0) S X1=START,X2=1 D C^%DTC S STOP=X K X1,X2,%H,X,%,%I "RTN","VAFCCOPT",21,0) S ENT=0,GBL="^TMP(""HLS"",$J)" "RTN","VAFCCOPT",22,0) ; "RTN","VAFCCOPT",23,0) K HL D INIT^HLFNC2("VAFC ADT-A08-SCHED SERVER",.HL) "RTN","VAFCCOPT",24,0) I $D(HL)=1 DO QUIT "RTN","VAFCCOPT",25,0) .I $P(HL,"^",2)="Server Protocol Disabled" "RTN","VAFCCOPT",26,0) .E S @ERRB@(1)=HL D EBULL^VAFHUTL2("","","",ERRB) "RTN","VAFCCOPT",27,0) ; "RTN","VAFCCOPT",28,0) S PSTR="2,3,7,10,18,39,44,50" "RTN","VAFCCOPT",29,0) ; "RTN","VAFCCOPT",30,0) N DGARRAY,DGCNT "RTN","VAFCCOPT",31,0) S COUNT=0 "RTN","VAFCCOPT",32,0) F S ENT=$O(^SC(ENT)) Q:(ENT="")!(ENT'?.N) D "RTN","VAFCCOPT",33,0) .S ENT1=START "RTN","VAFCCOPT",34,0) .S DGARRAY(1)=START_";"_STOP,DGARRAY("FLDS")="1;3",DGARRAY(2)=ENT "RTN","VAFCCOPT",35,0) .S DGCNT=$$SDAPI^SDAMA301(.DGARRAY) "RTN","VAFCCOPT",36,0) .; "RTN","VAFCCOPT",37,0) .;if there is data hanging from the 101 subscript, then "RTN","VAFCCOPT",38,0) .;it is a valid appointment, otherwise "RTN","VAFCCOPT",39,0) .;it is an error eg 01/20/2005 "RTN","VAFCCOPT",40,0) .I $D(^TMP($J,"SDAMA301",101))=1 Q ; DATABASE IS UNAVAILABLE "RTN","VAFCCOPT",41,0) .I DGCNT>0 S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",ENT,DFN)) Q:DFN="" D "RTN","VAFCCOPT",42,0) ..Q:'$D(^DPT(DFN,0)) "RTN","VAFCCOPT",43,0) ..S ENT1=0 F S ENT1=$O(^TMP($J,"SDAMA301",ENT,DFN,ENT1)) Q:ENT1=""!(ENT1'?.N1".".N) D "RTN","VAFCCOPT",44,0) ...S STAT=$P($P(^TMP($J,"SDAMA301",ENT,DFN,ENT1),"^",3),";") "RTN","VAFCCOPT",45,0) ...I STAT="NT" S ERR=$$CREATE() I +ERR>0 S VPTR=$P(ERR,"^",6) D GEN "RTN","VAFCCOPT",46,0) ...I +$G(ERR)<0 S @ERRB@(1)=ERR D EBULL^VAFHUTL2("","","",ERRB) "RTN","VAFCCOPT",47,0) .I DGCNT'=0 K ^TMP($J,"SDAMA301") "RTN","VAFCCOPT",48,0) D EXIT "RTN","VAFCCOPT",49,0) Q "RTN","VAFCCOPT",50,0) ; "RTN","VAFCCOPT",51,0) GEN I COUNT DO ;first time through its been done "RTN","VAFCCOPT",52,0) . K HL D INIT^HLFNC2("VAFC ADT-A08-SCHED SERVER",.HL) "RTN","VAFCCOPT",53,0) . I $D(HL)=1 DO "RTN","VAFCCOPT",54,0) . . S @ERRB@(1)=HL D EBULL^VAFHUTL2("","","",ERRB) "RTN","VAFCCOPT",55,0) I $D(HL)=1 S ENT="ZZZZEND",ENT1=9999999,ENT2=9999999 Q "RTN","VAFCCOPT",56,0) ; "RTN","VAFCCOPT",57,0) ; "RTN","VAFCCOPT",58,0) ;Generate the following segments: "RTN","VAFCCOPT",59,0) ;EVN "RTN","VAFCCOPT",60,0) S EVN=$$EVN^VAFHLEVN("A08","05") "RTN","VAFCCOPT",61,0) I +EVN=-1 S ERR="-1^Unable to generate EVN segment" Q "RTN","VAFCCOPT",62,0) ;PID "RTN","VAFCCOPT",63,0) S VAFPID=$$EN^VAFCPID(DFN,"2,3,4,5,6,7,8,9,11,12,13,14,16,19,29,30") "RTN","VAFCCOPT",64,0) ;ZPD "RTN","VAFCCOPT",65,0) S ZPD=$$EN^VAFHLZPD(DFN,"2,3,4,5,6,7,8,9,10,11,12,13,14,15") "RTN","VAFCCOPT",66,0) ;PV1 (outpatient) "RTN","VAFCCOPT",67,0) S PV1=$$OUT^VAFHLPV1(DFN,EVENT,EVDT,VPTR,PSTR) "RTN","VAFCCOPT",68,0) I +PV1=-1 S ERR="-1^Unable to generate PV1 segment" Q "RTN","VAFCCOPT",69,0) ; "RTN","VAFCCOPT",70,0) ; no dg1 segment will be created. No diagnosis "RTN","VAFCCOPT",71,0) ; information will be known at this stage. "RTN","VAFCCOPT",72,0) S COUNT=1 "RTN","VAFCCOPT",73,0) K ^TMP("HLS",$J) "RTN","VAFCCOPT",74,0) ; "RTN","VAFCCOPT",75,0) ; "RTN","VAFCCOPT",76,0) S @GBL@(COUNT)=EVN,COUNT=COUNT+1 "RTN","VAFCCOPT",77,0) MERGE @GBL@(COUNT)=VAFPID S COUNT=COUNT+1 "RTN","VAFCCOPT",78,0) S @GBL@(COUNT)=ZPD,COUNT=COUNT+1 "RTN","VAFCCOPT",79,0) S @GBL@(COUNT)=PV1 "RTN","VAFCCOPT",80,0) ; "RTN","VAFCCOPT",81,0) D GENERATE^HLMA("VAFC ADT-A08-SCHED SERVER","GM",1,,.HLRST) "RTN","VAFCCOPT",82,0) I $L($P(HLRST,2,99)) DO "RTN","VAFCCOPT",83,0) . S @ERRB@(1)=HLRST D EBULL^VAFHUTL2("","","",ERRB) "RTN","VAFCCOPT",84,0) . S ERRCNT=$G(ERRCNT)+1 "RTN","VAFCCOPT",85,0) . I $G(ERRCNT)>10 S ENT="ZZZZEND",ENT1=9999999,ENT2=9999999 "RTN","VAFCCOPT",86,0) Q "RTN","VAFCCOPT",87,0) ; "RTN","VAFCCOPT",88,0) EXIT K HLERR "RTN","VAFCCOPT",89,0) ; "RTN","VAFCCOPT",90,0) D KILL^HLTRANS "RTN","VAFCCOPT",91,0) K ERRCNT,VAFPID,^TMP("HLS",$J),SEQ,RESULT,MID "RTN","VAFCCOPT",92,0) K PSTR,ZPD,DG1,PID,PV1,MSH,EVN,ENT,ENT1,ENT2,DFN,START,STOP,GBL,HLSDT "RTN","VAFCCOPT",93,0) K EVDT,HLMTN,EVENT,COUNT,HLEVN,HLENTRY,ERR,VPTR,ERRB "RTN","VAFCCOPT",94,0) Q "RTN","VAFCCOPT",95,0) ; "RTN","VAFCCOPT",96,0) CREATE() ; "RTN","VAFCCOPT",97,0) ;creates new entry in pivot file "RTN","VAFCCOPT",98,0) N NODE,VPTR "RTN","VAFCCOPT",99,0) S EVDT=ENT1,VPTR=DFN_";DPT(" "RTN","VAFCCOPT",100,0) S NODE=$$PIVNW^VAFHPIVT(DFN,EVDT,2,VPTR) "RTN","VAFCCOPT",101,0) I +NODE=-1 Q NODE "RTN","VAFCCOPT",102,0) S EVENT=$P(NODE,":") "RTN","VAFCCOPT",103,0) Q EVENT_"^"_NODE "RTN","VAFHCCAP") 0^12^B19098716 "RTN","VAFHCCAP",1,0) VAFHCCAP ;ALB/CMM/PHH/EG OUTPATIENT CAPTURE TEST ; 1/20/05 1:21pm "RTN","VAFHCCAP",2,0) ;;5.3;Registration;**91,582,568,585**;Jun 06, 1996 "RTN","VAFHCCAP",3,0) ; "RTN","VAFHCCAP",4,0) CAP ; "RTN","VAFHCCAP",5,0) ;Only fire if check-in,check-out, add/edit add, add/edit change "RTN","VAFHCCAP",6,0) I ($G(SDAMEVT)<4)!($G(SDAMEVT)>7) Q "RTN","VAFHCCAP",7,0) ;quit if no action "RTN","VAFHCCAP",8,0) I +$G(SDATA("BEFORE","STATUS"))=3,+$G(SDATA("AFTER","STATUS"))=3 "RTN","VAFHCCAP",9,0) IF I $P($G(SDATA("AFTER","STATUS")),"^",3)'="ACTION REQ/CHECKED IN" "RTN","VAFHCCAP",10,0) IF I $P($G(SDATA("BEFORE","STATUS")),"^",3)'="NO ACTION TAKEN/TODAY" Q "RTN","VAFHCCAP",11,0) ;check to see if sending is on or off "RTN","VAFHCCAP",12,0) I '$$SEND^VAFHUTL() Q "RTN","VAFHCCAP",13,0) ; "RTN","VAFHCCAP",14,0) ;S ^TMP($J,"VAFHCCAP")="" "RTN","VAFHCCAP",15,0) ;I $D(^TMP($J,"VAFHCCAP")) G EN ;for debug "RTN","VAFHCCAP",16,0) ; "RTN","VAFHCCAP",17,0) ;Queue to run NOW, returns control back to outpatient event driver "RTN","VAFHCCAP",18,0) S ZTRTN="EN^VAFHCCAP",ZTDESC="PIMS Outpatient HL7 Capture" "RTN","VAFHCCAP",19,0) S ZTSAVE("SDHDL")="",ZTSAVE("SDAMEVT")="",ZTSAVE("SDATA")="" "RTN","VAFHCCAP",20,0) S ZTSAVE("^TMP(""SDEVT"",$J,")="",ZTIO="",ZTDTH=$H "RTN","VAFHCCAP",21,0) D ^%ZTLOAD "RTN","VAFHCCAP",22,0) ;W !?3,$G(ZTSK) "RTN","VAFHCCAP",23,0) Q "RTN","VAFHCCAP",24,0) ; "RTN","VAFHCCAP",25,0) EN ; "RTN","VAFHCCAP",26,0) N DFN,HLD,EVDT,CHK,ERR,SEND,NEW,EVENT,HOSP,THLD,PTR,REM,HPTR "RTN","VAFHCCAP",27,0) ;Only fire if check-in,check-out, add/edit add, add/edit change "RTN","VAFHCCAP",28,0) I SDAMEVT<4!(SDAMEVT>7) Q "RTN","VAFHCCAP",29,0) ; "RTN","VAFHCCAP",30,0) ;Appointments "RTN","VAFHCCAP",31,0) I SDAMEVT=4!(SDAMEVT=5) D "RTN","VAFHCCAP",32,0) .S DFN=$P(SDATA,"^",2),EVDT=$P(SDATA,"^",3),PTR=$$GETPTR^VAFHCUTL(1),PTR=PTR_";SCE(",(CHK,UP,REM)="" "RTN","VAFHCCAP",33,0) .I SDAMEVT=4 S PTR=DFN_";DPT(" ;check-in or unscheduled visit check-in "RTN","VAFHCCAP",34,0) .;Need to check if deleting check-out "RTN","VAFHCCAP",35,0) .;if deleting check-out and no pivot file entry exists don't send "RTN","VAFHCCAP",36,0) .I +$G(SDATA("AFTER","STATUS"))=3&(+$G(SDATA("BEFORE","STATUS"))=2) S CHK=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,PTR),PTR=$$UPPTR(DFN,EVDT) S:PTR="@" REM=1 S:+CHK>0 UP=$$UPDATE^VAFHUTL(+CHK,EVDT,PTR,REM) S:+CHK<0!(+UP<0) SEND="N" "RTN","VAFHCCAP",37,0) .;set send to N if deleting and not in pivot file "RTN","VAFHCCAP",38,0) .I '$D(SEND) D "RTN","VAFHCCAP",39,0) ..S HLD=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,PTR) "RTN","VAFHCCAP",40,0) ..I +HLD=-1 S HPTR=DFN_";DPT(",HLD=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,HPTR) I +HLD'=-1 S UP=$$UPDATE^VAFHUTL(+HLD,EVDT,PTR,"") "RTN","VAFHCCAP",41,0) ..I +HLD=-1 S HLD=$$PIVNW^VAFHPIVT(DFN,EVDT,2,PTR) "RTN","VAFHCCAP",42,0) ..S EVENT=$P(HLD,":"),ERR=$$OA08^VAFHCA08(DFN,EVENT,EVDT,PTR,"2,3,4,5,6,7,8,9,11,12,13,14,16,19","2,3,4,5,6,7,8,9,10,11,12,13,14,15","A","A") "RTN","VAFHCCAP",43,0) ; "RTN","VAFHCCAP",44,0) ;Stop codes, Add/Edits "RTN","VAFHCCAP",45,0) I SDAMEVT=6!(SDAMEVT=7) D "RTN","VAFHCCAP",46,0) .N HLD,STOP,THLD,REMOVE,UP "RTN","VAFHCCAP",47,0) .S HLD="",STOP="N",ERR="" "RTN","VAFHCCAP",48,0) .F K EVENT S REMOVE="N",HLD=$O(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD)) Q:HLD=""!(STOP="Y") D "RTN","VAFHCCAP",49,0) ..I ^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER")'=""&($P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER"),"^",6)'="") S STOP="Y" Q "RTN","VAFHCCAP",50,0) ..;If STOP="Y" stop code was not stand alone "RTN","VAFHCCAP",51,0) ..;If STOP="N" stop code is stand alone "RTN","VAFHCCAP",52,0) ..I ^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER")="" D "RTN","VAFHCCAP",53,0) ...S REMOVE="Y",DFN=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"BEFORE"),"^",2),EVDT=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"BEFORE"),"^"),PTR=HLD_";SCE(" "RTN","VAFHCCAP",54,0) ...S EVENT=$$PIVCHK^VAFHPIVT(DFN,EVDT,2,PTR) "RTN","VAFHCCAP",55,0) ..I ^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER")'="" D "RTN","VAFHCCAP",56,0) ...S DFN=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER"),"^",2),EVDT=$P(^TMP("SDEVT",$J,SDHDL,2,"SDOE",HLD,0,"AFTER"),"^"),PTR=HLD_";SCE(" "RTN","VAFHCCAP",57,0) ..I '$D(EVENT) S THLD=$$PIVNW^VAFHPIVT(DFN,EVDT,2,PTR),EVENT=$P(THLD,":") "RTN","VAFHCCAP",58,0) ..I REMOVE="Y" S PTR="@",UP=$$UPDATE^VAFHUTL(+EVENT,EVDT,PTR,1) "RTN","VAFHCCAP",59,0) ..I +EVENT>0 S ERR=$$OA08^VAFHCA08(DFN,EVENT,EVDT,PTR,"2,3,4,5,6,7,8,9,11,12,13,14,16,19","2,3,4,5,6,7,8,9,10,11,12,13,14,15","A","A") "RTN","VAFHCCAP",60,0) EXIT ; "RTN","VAFHCCAP",61,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","VAFHCCAP",62,0) I +ERR<0 D ERROR(ERR,DFN) "RTN","VAFHCCAP",63,0) D KILL^HLTRANS "RTN","VAFHCCAP",64,0) Q "RTN","VAFHCCAP",65,0) ; "RTN","VAFHCCAP",66,0) ERROR(PNUM,DFN) ; "RTN","VAFHCCAP",67,0) ;Error message unable to generate A08 Message "RTN","VAFHCCAP",68,0) N GBL S GBL="^TMP($J,""ERR"")" "RTN","VAFHCCAP",69,0) I +PNUM<0 S @GBL@(0)="ERROR",@GBL@(1)=$P(PNUM,"^",2)_", unable to generate A08 Message" D EBULL^VAFHUTL2(DFN,"","",$P(GBL,")")_",") "RTN","VAFHCCAP",70,0) Q "RTN","VAFHCCAP",71,0) ; "RTN","VAFHCCAP",72,0) UPPTR(DFN,ADATE) ; "RTN","VAFHCCAP",73,0) ;Have deleted checkout, update variable pointer "RTN","VAFHCCAP",74,0) N PTR S PTR="@" "RTN","VAFHCCAP",75,0) N DGARRAY,DGCOUNT,SDDATE "RTN","VAFHCCAP",76,0) S DGARRAY(4)=DFN,DGARRAY(1)=ADATE_";"_ADATE,DGARRAY("FLDS")=3,DGARRAY("SORT")="P" "RTN","VAFHCCAP",77,0) S DGCOUNT=$$SDAPI^SDAMA301(.DGARRAY) "RTN","VAFHCCAP",78,0) ; "RTN","VAFHCCAP",79,0) ;if there is data hanging from the 101 or 116 "RTN","VAFHCCAP",80,0) ;subscript, then it is a valid appointment "RTN","VAFHCCAP",81,0) ;otherwise, it is an error eg 01/20/2005 "RTN","VAFHCCAP",82,0) I DGCOUNT<0,$D(^TMP($J,"SDAMA301",101))=1 Q PTR "RTN","VAFHCCAP",83,0) I DGCOUNT<0,$D(^TMP($J,"SDAMA301",116))=1 Q PTR "RTN","VAFHCCAP",84,0) I DGCOUNT>0 D "RTN","VAFHCCAP",85,0) .S SDDATE=0 "RTN","VAFHCCAP",86,0) .F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDDATE)) Q:'SDDATE D "RTN","VAFHCCAP",87,0) ..I SDDATE=ADATE S PTR=DFN_";DPT(" "RTN","VAFHCCAP",88,0) I DGCOUNT'=0 K ^TMP($J,"SDAMA301") "RTN","VAFHCCAP",89,0) Q PTR "RTN","VAFHCOPT") 0^13^B9367770 "RTN","VAFHCOPT",1,0) VAFHCOPT ;ALB/CM/PKE/PHH/EG OUTPATIENT APPT (HL7 MESS) NIGHT JOB ; 1/20/05 1:23pm "RTN","VAFHCOPT",2,0) ;;5.3;Registration;**91,568,585**;Aug 13, 1993 "RTN","VAFHCOPT",3,0) ; "RTN","VAFHCOPT",4,0) ;This routine will loop through the Hospital Location file "S" node "RTN","VAFHCOPT",5,0) ;and generate an A08 message for all appointments for today "RTN","VAFHCOPT",6,0) ;that have a status of "No action taken" or "Future" "RTN","VAFHCOPT",7,0) ; "RTN","VAFHCOPT",8,0) EN ; "RTN","VAFHCOPT",9,0) ;Check to see if sending is on or off "RTN","VAFHCOPT",10,0) N GO "RTN","VAFHCOPT",11,0) S GO=$$SEND^VAFHUTL() "RTN","VAFHCOPT",12,0) I GO=0 Q "RTN","VAFHCOPT",13,0) ; "RTN","VAFHCOPT",14,0) S ERRB="^TMP($J,""ADT-ERR""," K ^TMP($J,"ADT-ERR") "RTN","VAFHCOPT",15,0) K HL D INIT^HLFNC2("VAFH A08",.HL) "RTN","VAFHCOPT",16,0) I $D(HL)=1 S ERR="-1^"_HL QUIT "RTN","VAFHCOPT",17,0) ; "RTN","VAFHCOPT",18,0) N STAT,X1,X2 "RTN","VAFHCOPT",19,0) ;This job should be set to run after midnight daily. "RTN","VAFHCOPT",20,0) D NOW^%DTC S START=X ;;;S START=2970101 "RTN","VAFHCOPT",21,0) S X1=START,X2=1 D C^%DTC S STOP=X K X1,X2,%H,X,%,%I "RTN","VAFHCOPT",22,0) ; "RTN","VAFHCOPT",23,0) S ENT=0,GBL="^TMP(""HLS"",$J)" K ^TMP("HLS",$J) "RTN","VAFHCOPT",24,0) ; "RTN","VAFHCOPT",25,0) N DGARRAY,DGCNT "RTN","VAFHCOPT",26,0) F S ENT=$O(^SC(ENT)) Q:(ENT="")!(ENT'?.N) D "RTN","VAFHCOPT",27,0) .S ENT1=START "RTN","VAFHCOPT",28,0) .S DGARRAY(1)=START_";"_STOP,DGARRAY("FLDS")="1;3",DGARRAY(2)=ENT "RTN","VAFHCOPT",29,0) .S DGCNT=$$SDAPI^SDAMA301(.DGARRAY) "RTN","VAFHCOPT",30,0) .; "RTN","VAFHCOPT",31,0) .;if there is data hanging from the 101 subscript, then "RTN","VAFHCOPT",32,0) .;it is a valid appointment, otherwise, it "RTN","VAFHCOPT",33,0) .;it is an error eg 01/20/2005 "RTN","VAFHCOPT",34,0) .I $D(^TMP($J,"SDAMA301",101))=1 Q "RTN","VAFHCOPT",35,0) .I DGCNT>0 S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",ENT,DFN)) Q:DFN="" D "RTN","VAFHCOPT",36,0) ..Q:'$D(^DPT(DFN,0)) "RTN","VAFHCOPT",37,0) ..S ENT1=0 F S ENT1=$O(^TMP($J,"SDAMA301",ENT,DFN,ENT1)) Q:ENT1=""!(ENT1'?.N1".".N) D "RTN","VAFHCOPT",38,0) ...S STAT=$P($P(^TMP($J,"SDAMA301",ENT,DFN,ENT1),"^",3),";") "RTN","VAFHCOPT",39,0) ...I STAT="NT" S ERR=$$CREATE() I +ERR>0 S VPTR=$P(ERR,"^",6) D GEN "RTN","VAFHCOPT",40,0) ...I +$G(ERR)<0 S @ERRB@(1)=ERR D EBULL^VAFHUTL2("","","",ERRB) "RTN","VAFHCOPT",41,0) .I DGCNT'=0 K ^TMP($J,"SDAMA301") "RTN","VAFHCOPT",42,0) D EXIT "RTN","VAFHCOPT",43,0) Q "RTN","VAFHCOPT",44,0) ; "RTN","VAFHCOPT",45,0) GEN ; "RTN","VAFHCOPT",46,0) ;Generate the following segments: "RTN","VAFHCOPT",47,0) ;MSH "RTN","VAFHCOPT",48,0) ; "RTN","VAFHCOPT",49,0) K HL D INIT^HLFNC2("VAFH A08",.HL) "RTN","VAFHCOPT",50,0) I $D(HL)=1 S ERR="-1^"_HL Q "RTN","VAFHCOPT",51,0) ;EVN "RTN","VAFHCOPT",52,0) S EVN=$$EVN^VAFHLEVN("A08","05") "RTN","VAFHCOPT",53,0) I +EVN=-1 S ERR="-1^Unable to generate EVN segment" Q "RTN","VAFHCOPT",54,0) ;PID "RTN","VAFHCOPT",55,0) S PID=$$EN^VAFHLPID(DFN,"2,3,4,5,6,7,8,9,11,12,13,14,16,19") "RTN","VAFHCOPT",56,0) ;ZPD "RTN","VAFHCOPT",57,0) S ZPD=$$EN^VAFHLZPD(DFN,"2,3,4,5,6,7,8,9,10,11,12,13,14,15") "RTN","VAFHCOPT",58,0) ;PV1 (outpatient) "RTN","VAFHCOPT",59,0) S PV1=$$OUT^VAFHLPV1(DFN,EVENT,EVDT,VPTR,"A") "RTN","VAFHCOPT",60,0) I +PV1=-1 S ERR="-1^Unable to generate PV1 segment" Q "RTN","VAFHCOPT",61,0) ; "RTN","VAFHCOPT",62,0) ; no dg1 segment will be created. No diagnosis "RTN","VAFHCOPT",63,0) ;information will be known at this stage. "RTN","VAFHCOPT",64,0) ; "RTN","VAFHCOPT",65,0) K ^TMP("HLS",$J) "RTN","VAFHCOPT",66,0) S COUNT=1 "RTN","VAFHCOPT",67,0) ; "RTN","VAFHCOPT",68,0) S @GBL@(COUNT)=EVN,COUNT=COUNT+1 "RTN","VAFHCOPT",69,0) S @GBL@(COUNT)=PID,COUNT=COUNT+1 "RTN","VAFHCOPT",70,0) S @GBL@(COUNT)=ZPD,COUNT=COUNT+1 "RTN","VAFHCOPT",71,0) S @GBL@(COUNT)=PV1 "RTN","VAFHCOPT",72,0) ; "RTN","VAFHCOPT",73,0) ; "RTN","VAFHCOPT",74,0) ; "RTN","VAFHCOPT",75,0) D GENERATE^HLMA("VAFH A08","GM",1,.HLRST,"",.HL) "RTN","VAFHCOPT",76,0) I HLRST,$P(HLRST,"^",2)="" "RTN","VAFHCOPT",77,0) E S @ERRB@(1)=HLRST D EBULL^VAFHUTL2("","","",ERRB) K HLERR "RTN","VAFHCOPT",78,0) Q "RTN","VAFHCOPT",79,0) EXIT ; "RTN","VAFHCOPT",80,0) D KILL^HLTRANS "RTN","VAFHCOPT",81,0) K @GBL "RTN","VAFHCOPT",82,0) K ZPD,DG1,PID,PV1,MSH,EVN,ENT,ENT1,ENT2,DFN,START,STOP,GBL,HLSDT "RTN","VAFHCOPT",83,0) K EVDT,HLMTN,EVENT,COUNT,HLEVN,HLENTRY,ERR,VPTR,ERRB "RTN","VAFHCOPT",84,0) Q "RTN","VAFHCOPT",85,0) ; "RTN","VAFHCOPT",86,0) CREATE() ; "RTN","VAFHCOPT",87,0) ;creates new entry in pivot file "RTN","VAFHCOPT",88,0) N NODE,VPTR "RTN","VAFHCOPT",89,0) S EVDT=ENT1,VPTR=DFN_";DPT(" "RTN","VAFHCOPT",90,0) S NODE=$$PIVNW^VAFHPIVT(DFN,EVDT,2,VPTR) "RTN","VAFHCOPT",91,0) I +NODE=-1 Q NODE "RTN","VAFHCOPT",92,0) S EVENT=$P(NODE,":") "RTN","VAFHCOPT",93,0) Q EVENT_"^"_NODE "RTN","VAFHUTL") 0^14^B21137485 "RTN","VAFHUTL",1,0) VAFHUTL ;ALB/CM/PHH/EG UTILITIES ROUTINE ; 1/21/05 2:11pm "RTN","VAFHUTL",2,0) ;;5.3;Registration;**91,151,568,585**;Jun 06, 1996 "RTN","VAFHUTL",3,0) ; "RTN","VAFHUTL",4,0) ; "RTN","VAFHUTL",5,0) LTD(DFN) ; "RTN","VAFHUTL",6,0) ;This function will find the last time seen at the facility "RTN","VAFHUTL",7,0) ; "RTN","VAFHUTL",8,0) ; Input: DFN -- pointer to the patient in file #2 "RTN","VAFHUTL",9,0) ; "RTN","VAFHUTL",10,0) ; Output: FileMan Date/time ^ I,D,R,A,S ^ HL7 Date/time ^ Variable PTR "RTN","VAFHUTL",11,0) ; "RTN","VAFHUTL",12,0) ; I = inpatient, D = discharge, R = Registration, A = Appointment "RTN","VAFHUTL",13,0) ; S = Stop Code "RTN","VAFHUTL",14,0) ; "RTN","VAFHUTL",15,0) ; If Unsuccessful, Output: -1^error message "RTN","VAFHUTL",16,0) ; "RTN","VAFHUTL",17,0) N LTD,X,FLG,LAST,VARPTR "RTN","VAFHUTL",18,0) ; "RTN","VAFHUTL",19,0) S FLG="" "RTN","VAFHUTL",20,0) ; - need a patient "RTN","VAFHUTL",21,0) I '$G(DFN) Q "-1^Missing Parameters for LTD function" "RTN","VAFHUTL",22,0) ; "RTN","VAFHUTL",23,0) ; - if current inpatient, set LTD = today and quit "RTN","VAFHUTL",24,0) I $G(^DPT(DFN,.105)) S LTD=DT,FLG="I" I $D(^DGPM("ATID1",DFN)) S LAST=9999999.9999999-($O(^DGPM("ATID1",DFN,""))) G LTDQ "RTN","VAFHUTL",25,0) ; "RTN","VAFHUTL",26,0) ; - get the last discharge date "RTN","VAFHUTL",27,0) S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD FLG="D",LAST=9999999.9999999-LTD,LTD=LAST\1 S:LTD>DT (LAST,LTD)=DT "RTN","VAFHUTL",28,0) ; "RTN","VAFHUTL",29,0) ; - get the last registration date and compare to LTD "RTN","VAFHUTL",30,0) S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X S:(X\1)>LTD LAST=X,LTD=X\1,FLG="R",VARPTR=DFN_";DPT(" "RTN","VAFHUTL",31,0) ; "RTN","VAFHUTL",32,0) ; - get the last appointment and compare to LTD "RTN","VAFHUTL",33,0) N SDDATE,SDARRAY,SDCLIEN,SDSTAT "RTN","VAFHUTL",34,0) S SDDATE=LTD,SDARRAY("FLDS")=3,SDARRAY(4)=DFN "RTN","VAFHUTL",35,0) I $$SDAPI^SDAMA301(.SDARRAY) D "RTN","VAFHUTL",36,0) .;if there is data hanging from the 101 level, then "RTN","VAFHUTL",37,0) .;it is a valid appointment, otherwise "RTN","VAFHUTL",38,0) .;it is an error eg 01/20/2005 "RTN","VAFHUTL",39,0) .I $D(^TMP($J,"SDAMA301",101))=1 Q "RTN","VAFHUTL",40,0) .S SDCLIEN=0 "RTN","VAFHUTL",41,0) .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(SDDATE>DT) D "RTN","VAFHUTL",42,0) ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(SDDATE>DT) D "RTN","VAFHUTL",43,0) ...S SDSTAT=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";") "RTN","VAFHUTL",44,0) ...I SDSTAT="" D "RTN","VAFHUTL",45,0) ....S LAST=SDDATE,LTD=SDDATE\1,FLG="A" "RTN","VAFHUTL",46,0) ....I $D(VARPTR) K VARPTR "RTN","VAFHUTL",47,0) K ^TMP($J,"SDAMA301") "RTN","VAFHUTL",48,0) ; "RTN","VAFHUTL",49,0) ; - get the last standalone after LTD "RTN","VAFHUTL",50,0) S X=$$GETLAST^SDOE(DFN,LTD_".9999") "RTN","VAFHUTL",51,0) I X S LAST=+$$SCE^DGSDU(X,1,0),LTD=LAST\1,FLG="S",VARPTR=X_";SCE(" "RTN","VAFHUTL",52,0) ; "RTN","VAFHUTL",53,0) LTDQ I '$D(LAST) Q "-1^No last date" "RTN","VAFHUTL",54,0) I '$D(VARPTR) S VARPTR=$$VPTR(FLG,DFN,LAST) "RTN","VAFHUTL",55,0) I +VARPTR<1 Q "-1^No last date" "RTN","VAFHUTL",56,0) Q LAST_"^"_FLG_"^"_$$HLDATE^HLFNC(LAST,"TS")_"^"_VARPTR "RTN","VAFHUTL",57,0) ; "RTN","VAFHUTL",58,0) ; "RTN","VAFHUTL",59,0) VPTR(TYPE,DFN,EDATE) ; "RTN","VAFHUTL",60,0) ;Gets pointer for inpatient/outpatient event "RTN","VAFHUTL",61,0) ; "RTN","VAFHUTL",62,0) I '$D(TYPE)!('$D(DFN))!('$D(EDATE)) Q "-1^Missing Parameters for VPTR function" "RTN","VAFHUTL",63,0) N PTR,IND "RTN","VAFHUTL",64,0) I TYPE'="A"&(TYPE'="D")&(TYPE'="I") Q "-1^NOT IN or OUT PATIENT" "RTN","VAFHUTL",65,0) I TYPE="I"!(TYPE="D") D "RTN","VAFHUTL",66,0) .;inpatient or discharge "RTN","VAFHUTL",67,0) .S IND=$O(^DGPM("APID",DFN,"")),PTR=$O(^DGPM("APID",DFN,IND,"")) "RTN","VAFHUTL",68,0) .I $D(^DGPM(PTR)) S PTR="-1^MISSING ENTRY" "RTN","VAFHUTL",69,0) .I +PTR>0 S PTR=PTR_";DGPM(" "RTN","VAFHUTL",70,0) I TYPE="A" D "RTN","VAFHUTL",71,0) .;outpatient appointment "RTN","VAFHUTL",72,0) .I $D(^SCE("ADFN",DFN,LAST)) S PTR=$O(^SCE("ADFN",DFN,LAST,"")) S:('$D(^SCE(+PTR,0))) PTR=DFN_";DPT(" S:($D(^SCE(+PTR,0))) PTR=PTR_";SCE(" "RTN","VAFHUTL",73,0) .I '$D(^SCE("ADFN",DFN,LAST)) S PTR=DFN_";DPT(" "RTN","VAFHUTL",74,0) Q PTR "RTN","VAFHUTL",75,0) ; "RTN","VAFHUTL",76,0) GETF(SEG) ;NOT USED ANY MORE "RTN","VAFHUTL",77,0) ;This function will return all of the available fields for the SEG "RTN","VAFHUTL",78,0) ;segment as found in the HL7 DHCP PARAMETER file, as a string, "RTN","VAFHUTL",79,0) ;separated by commas "RTN","VAFHUTL",80,0) ; "RTN","VAFHUTL",81,0) ;Input: SEG - HL7 Segment "RTN","VAFHUTL",82,0) ;Output: Successful - string of field numbers seperated by commas "RTN","VAFHUTL",83,0) ;If unsuccessful, -1^error message will be returned. "RTN","VAFHUTL",84,0) ; "RTN","VAFHUTL",85,0) ;NOTE: HL("SAN") must be defined as Sending Application in file 771 "RTN","VAFHUTL",86,0) ;N ENT,FLDS "RTN","VAFHUTL",87,0) ;I '$D(HLENTRY)!('$D(SEG)) Q "-1^MISSING PARAMETERS" "RTN","VAFHUTL",88,0) ;do lookup in #771 for HLENTRY "RTN","VAFHUTL",89,0) ;S DIC="^HL(770,",DIC(0)="MQZ",X=HLENTRY D ^DIC "RTN","VAFHUTL",90,0) ;I +Y<0 Q "-1^NO ENTRY IN FILE 771" "RTN","VAFHUTL",91,0) ;S ENT=$P(^HL(770,+Y,0),"^",8) I ENT="" Q "-1^NO ENTRY IN APPLICATION FIELD" "RTN","VAFHUTL",92,0) ; "RTN","VAFHUTL",93,0) N ENT,FLDS "RTN","VAFHUTL",94,0) I $G(HL("SAN"))]"",$G(SEG)]"" "RTN","VAFHUTL",95,0) E Q "-1^MISSING PARAMETERS HL(SAN)!SEG" "RTN","VAFHUTL",96,0) ; "RTN","VAFHUTL",97,0) S ENT=$O(^HL(771,"B",HL("SAN"),0)) "RTN","VAFHUTL",98,0) I 'ENT Q "-1^NO ENTRY IN FILE 771" "RTN","VAFHUTL",99,0) ; "RTN","VAFHUTL",100,0) S DIC="^HL(771,ENT,""SEG"",",X=SEG,DIC(0)="MQZ" D ^DIC "RTN","VAFHUTL",101,0) K DIC,X "RTN","VAFHUTL",102,0) I +Y<0 K Y Q "-1^NO ENTRY IN SUBFILE #771.05" "RTN","VAFHUTL",103,0) S FLDS=$P(^HL(771,ENT,"SEG",+Y,"F"),"^") K Y "RTN","VAFHUTL",104,0) Q FLDS "RTN","VAFHUTL",105,0) ; "RTN","VAFHUTL",106,0) UPDATE(PIVOT,ADATE,APTR,REMOVE) ; "RTN","VAFHUTL",107,0) ; "RTN","VAFHUTL",108,0) ;This function will allow the updating of PIVOT number entry, updating "RTN","VAFHUTL",109,0) ;EVENT DATE/TIME and the VARIABLE POINTER and setting of the DELETED "RTN","VAFHUTL",110,0) ;field. "RTN","VAFHUTL",111,0) ; "RTN","VAFHUTL",112,0) ;Input: PIVOT - Pivot Number "RTN","VAFHUTL",113,0) ; ADATE - Event Date/Time (new) "RTN","VAFHUTL",114,0) ; APTR - Variable Pointer (new) "RTN","VAFHUTL",115,0) ; REMOVE - 1 or null if 1 set DELETED field "RTN","VAFHUTL",116,0) ; "RTN","VAFHUTL",117,0) ;Output: 0 if successful "RTN","VAFHUTL",118,0) ; -1^error message if not successful "RTN","VAFHUTL",119,0) ; "RTN","VAFHUTL",120,0) I '$D(PIVOT) Q "-1^MISSING PARAMETERS" "RTN","VAFHUTL",121,0) I '$D(^VAT(391.71,"D",PIVOT)) Q "-1^NO PIVOT ENTRY" "RTN","VAFHUTL",122,0) I '$D(REMOVE) S REMOVE="" "RTN","VAFHUTL",123,0) I APTR?.N1";".A1"(" D "RTN","VAFHUTL",124,0) .I $P(APTR,";",2)="DPT(" S APTR="P.`"_+APTR "RTN","VAFHUTL",125,0) .I $P(APTR,";",2)="SCE(" S APTR="O.`"_+APTR "RTN","VAFHUTL",126,0) .I $P(APTR,";",2)="DGMP(" S APTR="I.`"_+APTR "RTN","VAFHUTL",127,0) S DA=$O(^VAT(391.71,"D",PIVOT,"")) I DA="" Q "-1^BAD CROSS REFERENCE" "RTN","VAFHUTL",128,0) S DIE="^VAT(391.71,",DIC(0)="MQZ",DR="" "RTN","VAFHUTL",129,0) I ADATE'="" S DR=DR_".01///"_ADATE_";" "RTN","VAFHUTL",130,0) I APTR'="" S DR=DR_".05///"_APTR_";" "RTN","VAFHUTL",131,0) S DR=DR_".07///"_REMOVE "RTN","VAFHUTL",132,0) L +^VAT(391.71,DA,0):5 "RTN","VAFHUTL",133,0) I '$T Q "-1^Unable to lock entry in Pivot file" "RTN","VAFHUTL",134,0) D ^DIE L -^VAT(391.71,DA,0) "RTN","VAFHUTL",135,0) K DIE,DR,DIC,DA,X,Y "RTN","VAFHUTL",136,0) Q 0 "RTN","VAFHUTL",137,0) ; "RTN","VAFHUTL",138,0) SEND(VAR1) ;this function will test for the on/off parameter to send ADT messages. "RTN","VAFHUTL",139,0) ;OUTPUTS 0 will indicate NOT to send "RTN","VAFHUTL",140,0) ; 1 will indicate TO send "RTN","VAFHUTL",141,0) ; 0 in second piece will indicate NOT to send HL7 v2.3 "RTN","VAFHUTL",142,0) ; 1 in second piece will indicate to send HL7 v2.3 "RTN","VAFHUTL",143,0) N VAR1 "RTN","VAFHUTL",144,0) S VAR1=$O(^DG(43,0)) "RTN","VAFHUTL",145,0) I +VAR1 S VAR1=$P($G(^DG(43,VAR1,"HL7")),"^",2,3) "RTN","VAFHUTL",146,0) Q VAR1 "RTN","VAFHUTL",147,0) ; "RTN","VAFHUTL",148,0) HLQ(DATA) ;this function returns the value passed to it or HLQ "RTN","VAFHUTL",149,0) I $G(DATA)="" Q HLQ "RTN","VAFHUTL",150,0) Q DATA "RTN","VAFHUTL",151,0) ; "RTN","VAFHUTL",152,0) NOSEND() ;function TURNS OFF the on/off parameter to send ADT messages. "RTN","VAFHUTL",153,0) ; used by init to disable all ADT HL7 protocols "RTN","VAFHUTL",154,0) ; "RTN","VAFHUTL",155,0) ;OUTPUTS 1 will indicate it was SET NOT to send "RTN","VAFHUTL",156,0) ; 0 will indicate it failed to SET IT NOT to send "RTN","VAFHUTL",157,0) ; "RTN","VAFHUTL",158,0) N VAR1 "RTN","VAFHUTL",159,0) S VAR1=$O(^DG(43,0)) "RTN","VAFHUTL",160,0) I +VAR1 S $P(^DG(43,+VAR1,"HL7"),"^",2,3)="0^0" Q 0 "RTN","VAFHUTL",161,0) Q 1 "RTN","VAFHUTL",162,0) ; "RTN","VAFHUTL",163,0) DPROTO(PNAM) ;returns 0 if protocol disabled field is not null, ie disabled "RTN","VAFHUTL",164,0) ; returns 1 if protocol is NOT disabled "RTN","VAFHUTL",165,0) I $G(PNAM)]"",$P($G(^ORD(101,+$O(^ORD(101,"B",PNAM,0)),0)),"^",3)]"" Q 0 "RTN","VAFHUTL",166,0) Q 1 "VER") 8.0^22.0 **END** **END**