source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFMO.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.0 KB
Line 
1DGPTFMO ;ALB/JDS/ADL - DGPTF PRINT TEMPLATE ; 11/15/06 2:52pm
2 ;;5.3;Registration;**195,397,510,590,594,606,683,729**;Aug 13, 1993;Build 59
3 ;;ADL;Updated for CSV Project;;Mar 4, 2003
4 ;FOR PTF REPORT CALLED FROM TEMPLATE DGPTF
5EN K A,B,AD,ADA,DGDD,DGFC,HEAD,DGPTFE,DGST,DGN,T
6 F I=0:0 S I=$O(^DGPT(D0,"M",I)) Q:I'>0 I $D(^(I,0)) S J=+$P(^(0),U,10) S:'J J=999999999 S:$D(T(J)) J=J+.01*I S T(J)=I
7 F I=0:0 S I=$O(T(I)) Q:I'>0 S DGM=$S($D(^DGPT(D0,"M",T(I),0)):^(0),1:"") I DGM]"" D WRITE
8 K T F I=0:0 S I=$O(^DGPT(D0,"S",I)) Q:I'>0 D SUR
9 S DGOP1=$S($D(^DGPT(D0,"401P")):^("401P"),1:"") I DGOP1]"" D HEAD:$Y>(IOSL-10) G Q:'DN D PROC
10 I $D(^DGPT(D0,"P")) D HEAD:$Y>(IOSL-10) G Q:'DN F I=0:0 S I=$O(^DGPT(D0,"P",I)) Q:I'>0 S DG601=^DGPT(D0,"P",I,0),Y=+DG601 D D^DGPTUTL W !!," Procedure Date: ",Y D 601
11 S DGPT=$G(^DGPT(D0,70)) I DGPT]"" G Q:'DN D DXLS
12 K %,DGL,DGM,DGPT,DGOP,DGOP1,DGF,DGP,DXLS,DGICD,L1,S1,T,J,K,DGPR,DGN,AGE,B,DA,DAM,DFN,DGST,DOB,DP,DRG,EXP,NO,P,PTF,DGPTFE,SD1,SEX,TAC,TRS,DGDS,DGTD,DGPROC,DG601,DGPTDAT
13 W ! ;F I=$Y:1:IOSL-1 W !
14 Q
15WRITE D HEAD:$Y>(IOSL-12) G Q:'DN S Y=$P(DGM,U,10),DGL=+$P(DGM,U,2),DGL=$S($D(^DIC(42.4,DGL,0)):^(0),1:""),DGL=$P(DGL,U,1) D D^DGPTUTL
16 W !!,"Movement Date: ",Y,?40,"Losing Specialty: ",$E(DGL,1,22),!,"Leave Days: ",$P(DGM,U,3),?40,"Pass Days: ",$P(DGM,U,4)
17 W !,"Treated for SC condition: ",$S($P(DGM,U,18)=1:"Yes",1:"No")
18 W:$P(DGM,U,31)'="" !,"Potentially Related to Combat: ",$S($P(DGM,U,31)="Y":"Yes",1:"No")
19 W:$P(DGM,U,26)'="" !,"Treated for AO condition: ",$S($P(DGM,U,26)="Y":"Yes",1:"No")
20 W:$P(DGM,U,27)'="" !,"Treated for IR condition: ",$S($P(DGM,U,27)="Y":"Yes",1:"No")
21 W:$P(DGM,U,28)'="" !,"Treated for EC condition: ",$S($P(DGM,U,28)="Y":"Yes",1:"No")
22 W:$P(DGM,U,29)'="" !,"Treated for MST condition: ",$S($P(DGM,U,29)="Y":"Yes",$P(DGM,U,29)="N":"No",1:"Declined to answer") ; added 6/17/98 for MST enhancement
23 W:$P(DGM,U,30)'="" !,"Treated for HEAD/NECK CA condition: ",$S($P(DGM,U,30)="Y":"Yes",1:"No")
24 W:T(I)=1 !,"Discharge "
25 S DGF="" F J=5:1:15 I J#10 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGM,U,J),$$GETDATE^ICDGTDRG(D0)),DGICD=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGICD]"" D
26 . W:DGF="" !!?13,"DX: " W $P(DGICD,U,3)_" ("_$P(DGICD,U)_")",!?17 S DGF=1
27 ;-- display expanded codes
28 S DG300=$S($D(^DGPT(D0,"M",T(I),300)):^(300),1:"") I DG300]"" D HEAD:$Y>(IOSL-6) D PRN2^DGPTFM8 W !
29 K DG300
30 ;Display TRANSFER DRG with description
31 Q:'$D(^DGPT(D0,"M",T(I),"P")) S DGTD=+^("P") Q:'$D(^ICD(DGTD,0)) W !?3,"TRANSFER DRG: ",DGTD," - "
32 N DXD,DGDX
33 S DXD=$$DRGD^ICDGTDRG(DGTD,"DGDX",,$$GETDATE^ICDGTDRG(D0)),DGDS=0
34 F S DGDS=$O(DGDX(DGDS)) Q:'+DGDS Q:DGDX(DGDS)=" " W !,DGDX(DGDS)
35 Q
36HEAD I $E(IOST,1)="C" W *7 R X:DTIME I X=U S DN=0 Q
37 S DC=DC+1 W @IOF,! X:$D(^UTILITY($J,2)) ^(2) W ! F K=1:1:IOM W "_"
38 W !,"("_$P(^DPT(+^DGPT(D0,0),0),U,1)_")",!
39 Q
40SUR D HEAD:$Y>(IOSL-7) G Q:'DN S S1=^DGPT(D0,"S",I,0),Y=+S1 D D^DGPTUTL W !!," Date of Surg: ",Y,?45,"Chief Surg: " S L=";"_$P(^DD(45.01,4,0),U,3),L1=";"_$P(S1,U,4)_":" W $P($P(L,L1,2),";",1)
41 W !," Anesth Tech: " S L=";"_$P(^DD(45.01,6,0),U,3),L1=";"_$P(S1,U,6)_":" W $P($P(L,L1,2),";",1),?45,"First Asst: " S L=";"_$P(^DD(45.01,5,0),U,3),L1=";"_$P(S1,U,5)_":" W $P($P(L,L1,2),";",1)
42 W !," Source of pay: " S L=";"_$P(^DD(45.01,7,0),U,3),L1=";"_$P(S1,U,7)_":" W $P($P(L,L1,2),";",1)
43 W ?46,"Surg spec: ",$S($D(^DIC(45.3,+$P(S1,U,3),0)):$P(^(0),U,2),1:"")
44 W !!,?7,"Surg/pro: " F K=1:1:5 S L=$P(S1,U,K+7) I L'="" S DGPTTMP=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(D0)) W $S(+DGPTTMP>0:$P(DGPTTMP,U,5)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
45 ;-- display expanded codes
46 S DG300=$S($D(^DGPT(D0,"S",I,300)):^(300),1:"") I DG300]"" D PRN3^DGPTFM8
47 K DG300
48 Q
49PROC S DGF="" F I=1:1:5 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGOP1,U,I),$$GETDATE^ICDGTDRG(D0)),DGOP=$S(DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGOP D
50 . W:'DGF !!?6,"Procedure: " W $P(DGOP,U,4)_" ("_$P(DGOP,U)_")",!?17 S DGF=1
51 Q
52601 ;print the procedures/dates from the 601 procedure multiple (eff. 10/1/87)
53 F J=5:1:9 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DG601,U,J),$$GETDATE^ICDGTDRG(D0)),DGPROC=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGPROC W !?17,$P(DGPROC,U,4)_" ("_$P(DGPROC,U)_")"
54 Q
55DXLS D HEAD:$Y>(IOSL-16) S DGPTDAT=$$GETDATE^ICDGTDRG(D0)
56 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT,U,10),DGPTDAT),DXLS=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DXLS]"" W !!?11,"PRINCIPAL DIAGNOSIS: ",$P(DXLS,U,3)_" ("_$P(DXLS,U)_")"
57 I 'DXLS S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT,U,11),DGPTDAT),DGP=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGP]"" W !!," Principal Diag: ",$P(DGP,U,3)_" ("_$P(DGP,U)_")"
58 S K=DGPT F I=16:1:24 D DSP
59 S K=$G(^DGPT(D0,71)) F I=1:1:4 D DSP
60 ;-- display expanded code information
61 S DG300=$S($D(^DGPT(D0,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
62 D EN2^DGPTF4 Q
63Q Q
64Q1 K ^UTILITY(U,$J),DG1 Q
65DT I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))," " W:Y#100 $J(Y#100\1,2),"," W Y\10000+1700 W:Y#1 " ",$E(Y_0,9,10),":",$E(Y_"000",11,12)
66 Q
67DSP S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10) D
68 .I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q
69 .W !,$P(J,U,4)_"("_$P(J,U,2)_")"
70 Q
Note: See TracBrowser for help on using the repository browser.