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

DGPTFMO.m

Go to the documentation of this file.
  1. DGPTFMO ;ALB/JDS/ADL,HIOFO/FT - DGPTF PRINT TEMPLATE ;10/15/14 2:25pm
  1. ;;5.3;Registration;**195,397,510,590,594,606,683,729,664,850,884,1057**;Aug 13, 1993;Build 17
  1. ;;ADL;Updated for CSV Project;;Mar 4, 2003
  1. ;
  1. ; ICDEX APIs - #5747
  1. ; ICDGTDRG APIs - #4052
  1. ; ICDXCODE APIs - #5699
  1. ;
  1. EN ;called from print template DGPT CENSUS INQUIRY
  1. K A,B,AD,ADA,DGDD,DGDDPTR,DGLOOP,DGFC,HEAD,DGPTFE,DGST,DGN,T,T82,DGM82,EFFDATE,IMPDATE,DGPTDAT
  1. F DGLOOP=4:1:7 D ;get the set of codes for fields 4,5,6, & 7 in 45.01 (401 data - Surgery)
  1. .K DGERROR,DGRESULT
  1. .S DGDDPTR(DGLOOP)=""
  1. .D FIELD^DID(45.01,DGLOOP,,"POINTER","DGRESULT","DGERROR")
  1. .I '$D(DGERROR) S DGDDPTR(DGLOOP)=$G(DGRESULT("POINTER"))
  1. K DGERROR,DGRESULT
  1. ;
  1. 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
  1. F I=0:0 S I=$O(T(I)) Q:I'>0 S DGM=$S($D(^DGPT(D0,"M",T(I),0)):^(0),1:"") D:DGM]"" WRITE
  1. ;
  1. K T F I=0:0 S I=$O(^DGPT(D0,"S",I)) Q:I'>0 D SUR
  1. S DGOP1=$S($D(^DGPT(D0,"401P")):^("401P"),1:"")
  1. I DGOP1]"" D HEAD:$Y>(IOSL-10) G Q:'DN D PROC
  1. 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 !!?5,"Procedure Date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P") D 601
  1. S DGPT=$G(^DGPT(D0,70)) I DGPT]"" G Q:'DN D DXLS
  1. 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
  1. W !
  1. K T82,DGM82,DGMPOA,DGLOOP
  1. Q
  1. WRITE 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
  1. ; ICD-10 CALLS
  1. D EFFDATE^DGPTIC10(D0)
  1. ;
  1. W !!,"Movement Date: ",Y,?40,"Losing Specialty: ",$E(DGL,1,22),!,"Leave Days: ",$P(DGM,U,3),?40,"Pass Days: ",$P(DGM,U,4)
  1. W !,"Treated for SC condition: ",$S($P(DGM,U,18)=1:"Yes",1:"No")
  1. W:$P(DGM,U,31)'="" !,"Potentially Related to Combat: ",$S($P(DGM,U,31)="Y":"Yes",1:"No")
  1. W:$P(DGM,U,26)'="" !,"Treated for AO condition: ",$S($P(DGM,U,26)="Y":"Yes",1:"No")
  1. W:$P(DGM,U,27)'="" !,"Treated for IR condition: ",$S($P(DGM,U,27)="Y":"Yes",1:"No")
  1. W:$P(DGM,U,28)'="" !,"Treated for service in SW Asia: ",$S($P(DGM,U,28)="Y":"Yes",1:"No")
  1. 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
  1. W:$P(DGM,U,30)'="" !,"Treated for HEAD/NECK CA condition: ",$S($P(DGM,U,30)="Y":"Yes",1:"No")
  1. W:$P(DGM,U,32)'="" !,"Treated for SHAD Condition: ",$S($P(DGM,U,32)="Y":"Yes",1:"No")
  1. W:T(I)=1 !,"Discharge "
  1. S DGF="",J=0 K DG501
  1. D PTFICD^DGPTFUT(501,D0,T(I),.DG501,1)
  1. F S J=$O(DG501(J)) Q:'J D
  1. . S DGMPOA=$P(DG501(J),U,2) ;get POA code
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DG501(J),U,1),EFFDATE)
  1. . W:DGF="" !!?5,"DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
  1. . D WRITECOD^DGPTIC10("DIAG",+$P(DG501(J),U,1),EFFDATE,2,1,8)
  1. . I $P(DGPTTMP,U,20)=30 W:$X>73 !," " W " (POA=",$S(DGMPOA]"":DGMPOA,1:"''"),")"
  1. . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
  1. . S DGF=1
  1. K DG501
  1. ;-- display expanded codes
  1. S DG300=$S($D(^DGPT(D0,"M",T(I),300)):^(300),1:"") I DG300]"" D HEAD:$Y>(IOSL-6) D PRN2^DGPTFM8 W !
  1. K DG300
  1. ;Display TRANSFER DRG with description
  1. Q:'$D(^DGPT(D0,"M",T(I),"P")) S DGTD=+^("P") Q:$P($$CODEC^ICDEX(80,DGTD),U,1)="-1" W !?3,"TRANSFER DRG: ",DGTD," - "
  1. N DXD,DGDX
  1. S DXD=$$DRGD^ICDGTDRG(DGTD,"DGDX",,$$GETDATE^ICDGTDRG(D0)),DGDS=0
  1. F S DGDS=$O(DGDX(DGDS)) Q:'+DGDS Q:DGDX(DGDS)=" " W !,DGDX(DGDS)
  1. Q
  1. S DC=DC+1 W @IOF,! X:$D(^UTILITY($J,2)) ^(2) W ! F K=1:1:IOM W "_"
  1. W !,"("_$P(^DPT(+^DGPT(D0,0),0),U,1)_")",!
  1. Q
  1. SUR ;
  1. 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: "
  1. S L=";"_DGDDPTR(4),L1=";"_$P(S1,U,4)_":" W $P($P(L,L1,2),";",1)
  1. W !," Anesth Tech: " S L=";"_DGDDPTR(6),L1=";"_$P(S1,U,6)_":" W $P($P(L,L1,2),";",1),?45,"First Asst: "
  1. S L=";"_DGDDPTR(5),L1=";"_$P(S1,U,5)_":" W $P($P(L,L1,2),";",1)
  1. W !," Source of pay: " S L=";"_DGDDPTR(7),L1=";"_$P(S1,U,7)_":" W $P($P(L,L1,2),";",1)
  1. W ?46,"Surg spec: ",$S($D(^DIC(45.3,+$P(S1,U,3),0)):$P(^(0),U,2),1:"")
  1. W !!,?5,"Surg/pro: ",$$GETLABEL^DGPTIC10(EFFDATE,"P"),!?7
  1. S K=0 K DG401
  1. D PTFICD^DGPTFUT(401,D0,I,.DG401,1)
  1. F S K=$O(DG401(K)) Q:'K D
  1. . S L=$P(DG401(K),U,1),DGPTTMP=""
  1. . I L'="" S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE) D
  1. .. D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,8)
  1. .. W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
  1. K DG401
  1. ;-- display expanded codes
  1. S DG300=$S($D(^DGPT(D0,"S",I,300)):^(300),1:"") I DG300]"" D PRN3^DGPTFM8
  1. K DG300
  1. Q
  1. PROC ;
  1. S DGF="" F I=1:1:5 D:$P(DGOP1,U,I)'=""
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DGOP1,U,I),EFFDATE)
  1. . W:'DGF !!?5,"Procedure: ",$$GETLABEL^DGPTIC10(EFFDATE,"P") S DGF=1
  1. . D WRITECOD^DGPTIC10("PROC",+$P(DGOP1,U,I),EFFDATE,2,1,8)
  1. . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
  1. Q
  1. 601 ;print the procedures/dates from the 601 procedure multiple (eff. 10/1/87)
  1. K DG601 S J=0
  1. D PTFICD^DGPTFUT(601,D0,I,.DG601,1)
  1. F S J=$O(DG601(J)) Q:'J D
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DG601(J),U,1),EFFDATE)
  1. . D WRITECOD^DGPTIC10("PROC",+$P(DG601(J),U,1),EFFDATE,2,1,8)
  1. . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
  1. K DG601
  1. Q
  1. DXLS ;
  1. N DGIDTS
  1. D HEAD:$Y>(IOSL-16)
  1. S DGPOA1=$P($G(^DGPT(D0,82)),U,1) ;POA for principal DX
  1. I +$P(DGPT,U,10) D
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGPT,U,10),EFFDATE),DXLS=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"")
  1. . W !!?5,"PRINCIPAL DIAGNOSIS: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
  1. . D WRITECOD^DGPTIC10("DIAG",+$P(DGPT,U,10),EFFDATE,2,1,8)
  1. . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
  1. . Q:$P(DGPTTMP,U,20)'=30 ;not an ICD10 DX
  1. . W " ["_$S(DGPOA1]"":DGPOA1,1:" ")_"]" ;show POA value
  1. ;
  1. I +$P(DGPT,U,11) D
  1. . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGPT,U,11),EFFDATE)
  1. . D WRITECOD^DGPTIC10("DIAG",+$P(DGPT,U,11),EFFDATE,2,1,8)
  1. . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
  1. . Q:$P(DGPTTMP,U,20)'=30 ;not an ICD10 DX
  1. . W " ["_$S(DGPOA1]"":DGPOA1,1:" ")_"]" ;show POA value. there shouldn't be one for old records
  1. K DG701,DGPOA1 S K=0
  1. D PTFICD^DGPTFUT(701,D0,,.DG701,1)
  1. F S K=$O(DG701(K)) Q:'K D:$P(DG701(K),U,1)>0 DSP
  1. K DG701
  1. ;-- display expanded code information
  1. S DG300=$S($D(^DGPT(D0,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
  1. D EN2^DGPTF4 ;calls ^DGPTFD to get DX/OP codes and then calls DGPTICD to calculate & store DRG value in PTF CLOSE OUT (#45.84) file.
  1. ; display initial date of service DG*5.3*1057
  1. S DGIDTS=+$P(^DGPT(D0,0),U,14) I DGIDTS>0 D
  1. .W !,"*Initial Date Of Service: "_$$EXTERNAL^DILFD(45,14,,$G(DGIDTS))
  1. .W !," *Utilize section 1 on the 101 screen for editing."
  1. .Q
  1. ;
  1. Q
  1. Q Q
  1. Q1 K ^UTILITY(U,$J),DG1
  1. Q
  1. DT 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)
  1. Q
  1. DSP ;
  1. S J=$$ICDDATA^ICDXCODE("DIAG",+$P(DG701(K),U,1),EFFDATE) D
  1. . D WRITECOD^DGPTIC10("DIAG",+$P(DG701(K),U,1),EFFDATE,2,1,8)
  1. . W $S(+J<1!('$P(J,U,10)):"*",1:"")
  1. . Q:$P(J,U,20)'=30 ;not an ICD-10 DX
  1. . W " ["_$S($P(DG701(K),U,2)]"":$P(DG701(K),U,2),1:" ")_"]"
  1. Q