DGPTFUT ;WOIFO/PLT,HIOFO/FT,WIOFO/PMK - PTF UTILITIES WITH API - ICR #6130 ;05/04/15 10:07am
;;5.3;Registration;**884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
;direct entry not allowed
QUIT
;
;dga=401, 501, 601, 701 or 801 of multiple fields of file #45 - ^dgpt
;dgb=ien of file #45 - ^dgpt
;.dgc=return values, initialized with kill, dgc(0)= discharge date for dga=701
; dgc(ien)= 401 sugery/procedure date, 501 movement date
; 601 procedure date, 701 discharge date
; 801 cpt record date/time
PTFIEN(DGA,DGB,DGC) ;get the ien's for 701,401,501,601,801 and recd dt/time
K DGC
N A,B,C
I DGA=701 S DGC(0)=$P($G(^DGPT(DGB,70)),U) QUIT
S A=$S(DGA=401:"S",DGA=501:"M",DGA=601:"P",DGA=801:"C",1:"") QUIT:A=""
;the piece # of the record date/time
S C=1 S:DGA=501 C=10
S B=0 F S B=$O(^DGPT(DGB,A,B)) QUIT:'B S DGC(B)=$P($G(^(B,0)),U,C)
QUIT
;
;dga=401, 501, 601, 701 or 801
;dgb=ien of file #45 - ptf
;dgc=ien of field multiple 401, 501, 601,801, nil if dga=701
;.dgd=return values, initialized with kill, dgd=^1 to ^15 demographic data, see tag 101
; ^16 rec date/time^17 405 ien if dga=501
; dgd(0)=prin dia ien^prin poa^icd code^poa external if dga=7/801
; dgd(1)=ien of icd1^poa1 internal^icd code^poa external, dgd(2)=...
; dgd(25)=ien of icd25^poa25 internal^icd code^poa external
; dgd(#) is undef if icd nil
;dge=1 for dgd(#,1)=short description, dgd(2,1)...,dgd(25,1)
; dge=2 dgd(1,2)=long description, dgd(2,2)...,dgd(25,2)
; dge=3 for both dgd(1,1) and dgd(1,2)..., dgd(25,1) and dgd(25,2)
PTFICD(DGA,DGB,DGC,DGD,DGE) ;get icd/poa/description of file #45
K DGD
S DGD=$$101(DGB) S:$P(DGD,U,2) $P(DGD,U,12)=$$GETLABEL^DGPTIC10($P(DGD,U,11),$S(DGA=701!(DGA=501):"D",DGA=401!(DGA=601):"P",1:""))
D @DGA
QUIT
;
;
;ptf=ien of file #45
;value= ^1 patient name^2 patient ien^3 adm dt^4 fac^5 fee basis
; ^6 status^7 type record^8 ptf ien generating this census rec
; ^9 census date ptr^10 discharge date^11 effective date
; ^12 icd label if from tag ptficd
101(PTF) ;ef= value of ptf demographic data
N A,B,C,D
QUIT:'PTF "" QUIT:'$D(^DGPT(PTF)) ""
S A=^DGPT(PTF,0),B=$G(^(70))
S C=$$GET7DATE^DGPTIC10(PTF)
S D=$P(^DPT(+A,0),U)_U_$P(A,U,1,4),$P(D,U,6)=$P(A,U,6)_U_$P(A,U,11)_U_$P(A,U,12)_U_$P(A,U,13)_U_$P(B,U)_U_C
QUIT D
;
;
401 ;401 multiple operation icd
N A,B,C
QUIT:'$D(^DGPT(DGB,"S",DGC,0)) S A=^(0),B=$G(^(1)),$P(DGD,U,16)=$P(A,U)
F C=8:1:27 S:$P(A,U,C)]"" DGD(C-7)=$P(A,U,C)_U_U_$$ICDCODE(80.1,$P(A,U,C))
F C=1:1:5 S:$P(B,U,C)]"" DGD(C+20)=$P(B,U,C)_U_U_$$ICDCODE(80.1,$P(B,U,C))
I $G(DGE) D DOPDES(80.1)
QUIT
;
;
501 ;501 multiple - movement icd/poa
N A,B,C,D
QUIT:'$D(^DGPT(DGB,"M",DGC,0)) S A=^(0),B=$G(^(81)),C=$G(^(82)),$P(DGD,U,16)=$P(A,U,10)
F D=5:1:9 S:$P(A,U,D)]"" DGD(D-4)=$P(A,U,D)_U_$P(C,U,D-4)_U_$$ICDCODE(80,$P(A,U,D))_U_$S($P(C,U,D-4)]"":$$EXTERNAL^DILFD(45.02,82.01,"",$P(C,U,D-4)),1:"")
F D=11:1:15 S:$P(A,U,D)]"" DGD(D-5)=$P(A,U,D)_U_$P(C,U,D-5)_U_$$ICDCODE(80,$P(A,U,D))_U_$S($P(C,U,D-5)]"":$$EXTERNAL^DILFD(45.02,82.01,"",$P(C,U,D-5)),1:"")
F D=1:1:15 S:$P(B,U,D)]"" DGD(D+10)=$P(B,U,D)_U_$P(C,U,D+10)_U_$$ICDCODE(80,$P(B,U,D))_U_$S($P(C,U,D+10)]"":$$EXTERNAL^DILFD(45.02,82.01,"",$P(C,U,D+10)),1:"")
I $G(DGE) D DOPDES(80)
QUIT
;
;
601 ;601 multiple - procedure icd
N A,B,C
QUIT:'$D(^DGPT(DGB,"P",DGC,0)) S A=^(0),B=$G(^(1)),$P(DGD,U,16)=$P(A,U)
F C=5:1:24 S:$P(A,U,C)]"" DGD(C-4)=$P(A,U,C)_U_U_$$ICDCODE(80.1,$P(A,U,C))
F C=1:1:5 S:$P(B,U,C)]"" DGD(C+20)=$P(B,U,C)_U_U_$$ICDCODE(80.1,$P(B,U,C))
I $G(DGE) D DOPDES(80.1)
QUIT
;
;
701 ;primary and secondary diagnosis icd/poa
N A,B,C,D,E
QUIT:'$D(^DGPT(DGB,0)) S A=$G(^(70)),B=$G(^(71)),C=$G(^(82))
S E=$P(A,U,10) S:E="" E=$P(A,U,11)
S:E]"" DGD(0)=E_U_$P(C,U,1)_U_$$ICDCODE(80,E)_U_$S($P(C,U,1)]"":$$EXTERNAL^DILFD(45,82.01,"",$P(C,U,1)),1:"")
F D=16:1:24 S:$P(A,U,D)]"" DGD(D-15)=$P(A,U,D)_U_$P(C,U,D-14)_U_$$ICDCODE(80,$P(A,U,D))_U_$S($P(C,U,D-14)]"":$$EXTERNAL^DILFD(45,82.02,"",$P(C,U,D-14)),1:"")
F D=1:1:15 S:$P(B,U,D)]"" DGD(D+9)=$P(B,U,D)_U_$P(C,U,D+10)_U_$$ICDCODE(80,$P(B,U,D))_U_$S($P(C,U,D+10)]"":$$EXTERNAL^DILFD(45,82.02,"",$P(C,U,D+10)),1:"")
I $G(DGE) D DOPDES(80)
QUIT
;
;
801 ;801 multiple - cpt code
N A
QUIT:'$D(^DGPT(DGB,"C",DGC,0)) S A=^(0)
S:$P(A,U,4)]"" DGD(0)=$P(A,U,4)_U_U_$$ICDCODE(80,$P(A,U,4))
I $G(DGE) D DOPDES(80)
QUIT
;
;
;dga=80 or 80.1
DOPDES(DGA) ;set diag,oper and procet short/long description in dgd array
N DGB
S DGB="" F S DGB=$O(DGD(DGB)) QUIT:DGB="" S:"13"[DGE DGD(DGB,1)=$$ICDDES(DGA,+DGD(DGB),$P(DGD,U,11),1) S:"23"[DGE DGD(DGB,2)=$$ICDDES(DGA,+DGD(DGB),$P(DGD,U,11),2)
;
;
;
;a= file #80 or #80.1
;b=ien
ICDCODE(A,B) ;ef icd code or nil
N C
S C=$$CODEC^ICDEX(A,B)
QUIT $S(C=-1:"",1:C)
;
;
;dgfn=80 for icd, 80.1 for opration/procedure
;dgien=ien of dgfn
;dgedt=effective date
;a=1 for short description, 2=long
ICDDES(DGFN,DGIEN,DGEDT,A) ;ef= file 80 or 80.1 code description
QUIT:A=1 $$VST^ICDEX(DGFN,DGIEN,DGEDT)
QUIT $$VLT^ICDEX(DGFN,DGIEN,DGEDT)
;
;
STR401(DG0,DG1) ; Builds 25 piece string with OPERATION codes
; DG0 = file 45 ien
; DG1 = ien of 401 multiple
; Returns a string of 25 pieces containing the OPERATION codes
N DG401,DG401A,DGLOOP,DGSTRING
S DG0=$G(DG0),DG1=$G(DG1)
I 'DG0!'DG1 Q ""
S DG401=$G(^DGPT(DG0,"S",DG1,0)),DG401A=$G(^DGPT(DG0,"S",DG1,1)),DGSTRING=""
F DGLOOP=8:1:27 S $P(DGSTRING,U,DGLOOP-7)=$P(DG401,U,DGLOOP)
F DGLOOP=1:1:5 S $P(DGSTRING,U,DGLOOP+20)=$P(DG401A,U,DGLOOP)
Q DGSTRING
;
STR501(DG0,DG1) ; Builds 25 piece string with MOVEMENT codes
; DG0 = file 45 ien
; DG1 = ien of 501 multiple
; Returns a string of 25 pieces containing the MOVEMENT codes
N DG501,DG501A,DGLOOP,DGSTRING
S DG0=$G(DG0),DG1=$G(DG1)
I 'DG0!'DG1 Q ""
S DG501=$G(^DGPT(DG0,"M",DG1,0)),DG501A=$G(^DGPT(DG0,"M",DG1,81)),DGSTRING=""
F DGLOOP=5:1:9 S $P(DGSTRING,U,DGLOOP-4)=$P(DG501,U,DGLOOP)
F DGLOOP=11:1:15 S $P(DGSTRING,U,DGLOOP-5)=$P(DG501,U,DGLOOP)
F DGLOOP=1:1:15 S $P(DGSTRING,U,DGLOOP+10)=$P(DG501A,U,DGLOOP)
Q DGSTRING
;
STR601(DG0,DG1) ; Builds 25 piece string with PROCEDURE codes
; DG0 = file 45 ien
; DG1 = ien of 601 multiple
; Returns a string of 25 pieces containing the PROCEDURE codes
N DG601,DG601A,DGLOOP,DGSTRING
S DG0=$G(DG0),DG1=$G(DG1)
I 'DG0!'DG1 Q ""
S DG601=$G(^DGPT(DG0,"P",DG1,0)),DG601A=$G(^DGPT(DG0,"P",DG1,1)),DGSTRING=""
F DGLOOP=5:1:24 S $P(DGSTRING,U,DGLOOP-4)=$P(DG601,U,DGLOOP)
F DGLOOP=1:1:5 S $P(DGSTRING,U,DGLOOP+20)=$P(DG601A,U,DGLOOP)
Q DGSTRING
;
STR701(DG0) ; Builds 25 piece string with DIAGNOSTIC codes
; DG0 = file 45 ien
; Returns a string of 25 pieces containing the 701 codes. First piece is principal DX
N DG701,DG701A,DGLOOP,DGSTRING
S DG0=$G(DG0)
I 'DG0 Q ""
S DG701=$G(^DGPT(DG0,70)),DG701A=$G(^DGPT(DG0,71)),DGSTRING="",$P(DGSTRING,U,1)=$P(DG701,U,10)
F DGLOOP=16:1:24 S $P(DGSTRING,U,DGLOOP-14)=$P(DG701,U,DGLOOP)
F DGLOOP=1:1:15 S $P(DGSTRING,U,DGLOOP+10)=$P(DG701A,U,DGLOOP)
Q DGSTRING
;
STR701P(DG0) ; Builds 25 piece string with 701 Present On Admission (POA) codes
; DG0 = file 45 ien
; Returns a string of 25 pieces containing the 701 POA codes
N DG82,DGLOOP,DGSTRING
S DG0=$G(DG0)
I 'DG0 Q ""
S DG82=$G(^DGPT(DG0,82)),DGSTRING=""
F DGLOOP=1:1:25 S $P(DGSTRING,U,DGLOOP)=$P(DG82,U,DGLOOP)
Q DGSTRING
;
STR501P(DG0,DG1) ; Builds 25 piece string with 501 Present On Admission (POA) codes
; DG0 = file 45 ien
; DG1 = ien of 501 multiple
; Returns a string of 25 pieces containing the 501 POA codes
N DG82,DGLOOP,DGSTRING
S DG0=$G(DG0),DG1=$G(DG1)
I 'DG0!'DG1 Q ""
S DG82=$G(^DGPT(DG0,"M",DG1,82)),DGSTRING=""
F DGLOOP=1:1:25 S $P(DGSTRING,U,DGLOOP)=$P(DG82,U,DGLOOP)
Q DGSTRING
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFUT 7983 printed Oct 16, 2024@18:53:13 Page 2
DGPTFUT ;WOIFO/PLT,HIOFO/FT,WIOFO/PMK - PTF UTILITIES WITH API - ICR #6130 ;05/04/15 10:07am
+1 ;;5.3;Registration;**884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;direct entry not allowed
+5 QUIT
+6 ;
+7 ;dga=401, 501, 601, 701 or 801 of multiple fields of file #45 - ^dgpt
+8 ;dgb=ien of file #45 - ^dgpt
+9 ;.dgc=return values, initialized with kill, dgc(0)= discharge date for dga=701
+10 ; dgc(ien)= 401 sugery/procedure date, 501 movement date
+11 ; 601 procedure date, 701 discharge date
+12 ; 801 cpt record date/time
PTFIEN(DGA,DGB,DGC) ;get the ien's for 701,401,501,601,801 and recd dt/time
+1 KILL DGC
+2 NEW A,B,C
+3 IF DGA=701
SET DGC(0)=$PIECE($GET(^DGPT(DGB,70)),U)
QUIT
+4 SET A=$SELECT(DGA=401:"S",DGA=501:"M",DGA=601:"P",DGA=801:"C",1:"")
if A=""
QUIT
+5 ;the piece # of the record date/time
+6 SET C=1
if DGA=501
SET C=10
+7 SET B=0
FOR
SET B=$ORDER(^DGPT(DGB,A,B))
if 'B
QUIT
SET DGC(B)=$PIECE($GET(^(B,0)),U,C)
+8 QUIT
+9 ;
+10 ;dga=401, 501, 601, 701 or 801
+11 ;dgb=ien of file #45 - ptf
+12 ;dgc=ien of field multiple 401, 501, 601,801, nil if dga=701
+13 ;.dgd=return values, initialized with kill, dgd=^1 to ^15 demographic data, see tag 101
+14 ; ^16 rec date/time^17 405 ien if dga=501
+15 ; dgd(0)=prin dia ien^prin poa^icd code^poa external if dga=7/801
+16 ; dgd(1)=ien of icd1^poa1 internal^icd code^poa external, dgd(2)=...
+17 ; dgd(25)=ien of icd25^poa25 internal^icd code^poa external
+18 ; dgd(#) is undef if icd nil
+19 ;dge=1 for dgd(#,1)=short description, dgd(2,1)...,dgd(25,1)
+20 ; dge=2 dgd(1,2)=long description, dgd(2,2)...,dgd(25,2)
+21 ; dge=3 for both dgd(1,1) and dgd(1,2)..., dgd(25,1) and dgd(25,2)
PTFICD(DGA,DGB,DGC,DGD,DGE) ;get icd/poa/description of file #45
+1 KILL DGD
+2 SET DGD=$$101(DGB)
if $PIECE(DGD,U,2)
SET $PIECE(DGD,U,12)=$$GETLABEL^DGPTIC10($PIECE(DGD,U,11),$SELECT(DGA=701!(DGA=501):"D",DGA=401!(DGA=601):"P",1:""))
+3 DO @DGA
+4 QUIT
+5 ;
+6 ;
+7 ;ptf=ien of file #45
+8 ;value= ^1 patient name^2 patient ien^3 adm dt^4 fac^5 fee basis
+9 ; ^6 status^7 type record^8 ptf ien generating this census rec
+10 ; ^9 census date ptr^10 discharge date^11 effective date
+11 ; ^12 icd label if from tag ptficd
101(PTF) ;ef= value of ptf demographic data
+1 NEW A,B,C,D
+2 if 'PTF
QUIT ""
if '$DATA(^DGPT(PTF))
QUIT ""
+3 SET A=^DGPT(PTF,0)
SET B=$GET(^(70))
+4 SET C=$$GET7DATE^DGPTIC10(PTF)
+5 SET D=$PIECE(^DPT(+A,0),U)_U_$PIECE(A,U,1,4)
SET $PIECE(D,U,6)=$PIECE(A,U,6)_U_$PIECE(A,U,11)_U_$PIECE(A,U,12)_U_$PIECE(A,U,13)_U_$PIECE(B,U)_U_C
+6 QUIT D
+7 ;
+8 ;
401 ;401 multiple operation icd
+1 NEW A,B,C
+2 if '$DATA(^DGPT(DGB,"S",DGC,0))
QUIT
SET A=^(0)
SET B=$GET(^(1))
SET $PIECE(DGD,U,16)=$PIECE(A,U)
+3 FOR C=8:1:27
if $PIECE(A,U,C)]""
SET DGD(C-7)=$PIECE(A,U,C)_U_U_$$ICDCODE(80.1,$PIECE(A,U,C))
+4 FOR C=1:1:5
if $PIECE(B,U,C)]""
SET DGD(C+20)=$PIECE(B,U,C)_U_U_$$ICDCODE(80.1,$PIECE(B,U,C))
+5 IF $GET(DGE)
DO DOPDES(80.1)
+6 QUIT
+7 ;
+8 ;
501 ;501 multiple - movement icd/poa
+1 NEW A,B,C,D
+2 if '$DATA(^DGPT(DGB,"M",DGC,0))
QUIT
SET A=^(0)
SET B=$GET(^(81))
SET C=$GET(^(82))
SET $PIECE(DGD,U,16)=$PIECE(A,U,10)
+3 FOR D=5:1:9
if $PIECE(A,U,D)]""
SET DGD(D-4)=$PIECE(A,U,D)_U_$PIECE(C,U,D-4)_U_$$ICDCODE(80,$PIECE(A,U,D))_U_$SELECT($PIECE(C,U,D-4)]"":$$EXTERNAL^DILFD(45.02,82.01,"",$PIECE(C,U,D-4)),1:"")
+4 FOR D=11:1:15
if $PIECE(A,U,D)]""
SET DGD(D-5)=$PIECE(A,U,D)_U_$PIECE(C,U,D-5)_U_$$ICDCODE(80,$PIECE(A,U,D))_U_$SELECT($PIECE(C,U,D-5)]"":$$EXTERNAL^DILFD(45.02,82.01,"",$PIECE(C,U,D-5)),1:"")
+5 FOR D=1:1:15
if $PIECE(B,U,D)]""
SET DGD(D+10)=$PIECE(B,U,D)_U_$PIECE(C,U,D+10)_U_$$ICDCODE(80,$PIECE(B,U,D))_U_$SELECT($PIECE(C,U,D+10)]"":$$EXTERNAL^DILFD(45.02,82.01,"",$PIECE(C,U,D+10)),1:"")
+6 IF $GET(DGE)
DO DOPDES(80)
+7 QUIT
+8 ;
+9 ;
601 ;601 multiple - procedure icd
+1 NEW A,B,C
+2 if '$DATA(^DGPT(DGB,"P",DGC,0))
QUIT
SET A=^(0)
SET B=$GET(^(1))
SET $PIECE(DGD,U,16)=$PIECE(A,U)
+3 FOR C=5:1:24
if $PIECE(A,U,C)]""
SET DGD(C-4)=$PIECE(A,U,C)_U_U_$$ICDCODE(80.1,$PIECE(A,U,C))
+4 FOR C=1:1:5
if $PIECE(B,U,C)]""
SET DGD(C+20)=$PIECE(B,U,C)_U_U_$$ICDCODE(80.1,$PIECE(B,U,C))
+5 IF $GET(DGE)
DO DOPDES(80.1)
+6 QUIT
+7 ;
+8 ;
701 ;primary and secondary diagnosis icd/poa
+1 NEW A,B,C,D,E
+2 if '$DATA(^DGPT(DGB,0))
QUIT
SET A=$GET(^(70))
SET B=$GET(^(71))
SET C=$GET(^(82))
+3 SET E=$PIECE(A,U,10)
if E=""
SET E=$PIECE(A,U,11)
+4 if E]""
SET DGD(0)=E_U_$PIECE(C,U,1)_U_$$ICDCODE(80,E)_U_$SELECT($PIECE(C,U,1)]"":$$EXTERNAL^DILFD(45,82.01,"",$PIECE(C,U,1)),1:"")
+5 FOR D=16:1:24
if $PIECE(A,U,D)]""
SET DGD(D-15)=$PIECE(A,U,D)_U_$PIECE(C,U,D-14)_U_$$ICDCODE(80,$PIECE(A,U,D))_U_$SELECT($PIECE(C,U,D-14)]"":$$EXTERNAL^DILFD(45,82.02,"",$PIECE(C,U,D-14)),1:"")
+6 FOR D=1:1:15
if $PIECE(B,U,D)]""
SET DGD(D+9)=$PIECE(B,U,D)_U_$PIECE(C,U,D+10)_U_$$ICDCODE(80,$PIECE(B,U,D))_U_$SELECT($PIECE(C,U,D+10)]"":$$EXTERNAL^DILFD(45,82.02,"",$PIECE(C,U,D+10)),1:"")
+7 IF $GET(DGE)
DO DOPDES(80)
+8 QUIT
+9 ;
+10 ;
801 ;801 multiple - cpt code
+1 NEW A
+2 if '$DATA(^DGPT(DGB,"C",DGC,0))
QUIT
SET A=^(0)
+3 if $PIECE(A,U,4)]""
SET DGD(0)=$PIECE(A,U,4)_U_U_$$ICDCODE(80,$PIECE(A,U,4))
+4 IF $GET(DGE)
DO DOPDES(80)
+5 QUIT
+6 ;
+7 ;
+8 ;dga=80 or 80.1
DOPDES(DGA) ;set diag,oper and procet short/long description in dgd array
+1 NEW DGB
+2 SET DGB=""
FOR
SET DGB=$ORDER(DGD(DGB))
if DGB=""
QUIT
if "13"[DGE
SET DGD(DGB,1)=$$ICDDES(DGA,+DGD(DGB),$PIECE(DGD,U,11),1)
if "23"[DGE
SET DGD(DGB,2)=$$ICDDES(DGA,+DGD(DGB),$PIECE(DGD,U,11),2)
+3 ;
+4 ;
+5 ;
+6 ;a= file #80 or #80.1
+7 ;b=ien
ICDCODE(A,B) ;ef icd code or nil
+1 NEW C
+2 SET C=$$CODEC^ICDEX(A,B)
+3 QUIT $SELECT(C=-1:"",1:C)
+4 ;
+5 ;
+6 ;dgfn=80 for icd, 80.1 for opration/procedure
+7 ;dgien=ien of dgfn
+8 ;dgedt=effective date
+9 ;a=1 for short description, 2=long
ICDDES(DGFN,DGIEN,DGEDT,A) ;ef= file 80 or 80.1 code description
+1 if A=1
QUIT $$VST^ICDEX(DGFN,DGIEN,DGEDT)
+2 QUIT $$VLT^ICDEX(DGFN,DGIEN,DGEDT)
+3 ;
+4 ;
STR401(DG0,DG1) ; Builds 25 piece string with OPERATION codes
+1 ; DG0 = file 45 ien
+2 ; DG1 = ien of 401 multiple
+3 ; Returns a string of 25 pieces containing the OPERATION codes
+4 NEW DG401,DG401A,DGLOOP,DGSTRING
+5 SET DG0=$GET(DG0)
SET DG1=$GET(DG1)
+6 IF 'DG0!'DG1
QUIT ""
+7 SET DG401=$GET(^DGPT(DG0,"S",DG1,0))
SET DG401A=$GET(^DGPT(DG0,"S",DG1,1))
SET DGSTRING=""
+8 FOR DGLOOP=8:1:27
SET $PIECE(DGSTRING,U,DGLOOP-7)=$PIECE(DG401,U,DGLOOP)
+9 FOR DGLOOP=1:1:5
SET $PIECE(DGSTRING,U,DGLOOP+20)=$PIECE(DG401A,U,DGLOOP)
+10 QUIT DGSTRING
+11 ;
STR501(DG0,DG1) ; Builds 25 piece string with MOVEMENT codes
+1 ; DG0 = file 45 ien
+2 ; DG1 = ien of 501 multiple
+3 ; Returns a string of 25 pieces containing the MOVEMENT codes
+4 NEW DG501,DG501A,DGLOOP,DGSTRING
+5 SET DG0=$GET(DG0)
SET DG1=$GET(DG1)
+6 IF 'DG0!'DG1
QUIT ""
+7 SET DG501=$GET(^DGPT(DG0,"M",DG1,0))
SET DG501A=$GET(^DGPT(DG0,"M",DG1,81))
SET DGSTRING=""
+8 FOR DGLOOP=5:1:9
SET $PIECE(DGSTRING,U,DGLOOP-4)=$PIECE(DG501,U,DGLOOP)
+9 FOR DGLOOP=11:1:15
SET $PIECE(DGSTRING,U,DGLOOP-5)=$PIECE(DG501,U,DGLOOP)
+10 FOR DGLOOP=1:1:15
SET $PIECE(DGSTRING,U,DGLOOP+10)=$PIECE(DG501A,U,DGLOOP)
+11 QUIT DGSTRING
+12 ;
STR601(DG0,DG1) ; Builds 25 piece string with PROCEDURE codes
+1 ; DG0 = file 45 ien
+2 ; DG1 = ien of 601 multiple
+3 ; Returns a string of 25 pieces containing the PROCEDURE codes
+4 NEW DG601,DG601A,DGLOOP,DGSTRING
+5 SET DG0=$GET(DG0)
SET DG1=$GET(DG1)
+6 IF 'DG0!'DG1
QUIT ""
+7 SET DG601=$GET(^DGPT(DG0,"P",DG1,0))
SET DG601A=$GET(^DGPT(DG0,"P",DG1,1))
SET DGSTRING=""
+8 FOR DGLOOP=5:1:24
SET $PIECE(DGSTRING,U,DGLOOP-4)=$PIECE(DG601,U,DGLOOP)
+9 FOR DGLOOP=1:1:5
SET $PIECE(DGSTRING,U,DGLOOP+20)=$PIECE(DG601A,U,DGLOOP)
+10 QUIT DGSTRING
+11 ;
STR701(DG0) ; Builds 25 piece string with DIAGNOSTIC codes
+1 ; DG0 = file 45 ien
+2 ; Returns a string of 25 pieces containing the 701 codes. First piece is principal DX
+3 NEW DG701,DG701A,DGLOOP,DGSTRING
+4 SET DG0=$GET(DG0)
+5 IF 'DG0
QUIT ""
+6 SET DG701=$GET(^DGPT(DG0,70))
SET DG701A=$GET(^DGPT(DG0,71))
SET DGSTRING=""
SET $PIECE(DGSTRING,U,1)=$PIECE(DG701,U,10)
+7 FOR DGLOOP=16:1:24
SET $PIECE(DGSTRING,U,DGLOOP-14)=$PIECE(DG701,U,DGLOOP)
+8 FOR DGLOOP=1:1:15
SET $PIECE(DGSTRING,U,DGLOOP+10)=$PIECE(DG701A,U,DGLOOP)
+9 QUIT DGSTRING
+10 ;
STR701P(DG0) ; Builds 25 piece string with 701 Present On Admission (POA) codes
+1 ; DG0 = file 45 ien
+2 ; Returns a string of 25 pieces containing the 701 POA codes
+3 NEW DG82,DGLOOP,DGSTRING
+4 SET DG0=$GET(DG0)
+5 IF 'DG0
QUIT ""
+6 SET DG82=$GET(^DGPT(DG0,82))
SET DGSTRING=""
+7 FOR DGLOOP=1:1:25
SET $PIECE(DGSTRING,U,DGLOOP)=$PIECE(DG82,U,DGLOOP)
+8 QUIT DGSTRING
+9 ;
STR501P(DG0,DG1) ; Builds 25 piece string with 501 Present On Admission (POA) codes
+1 ; DG0 = file 45 ien
+2 ; DG1 = ien of 501 multiple
+3 ; Returns a string of 25 pieces containing the 501 POA codes
+4 NEW DG82,DGLOOP,DGSTRING
+5 SET DG0=$GET(DG0)
SET DG1=$GET(DG1)
+6 IF 'DG0!'DG1
QUIT ""
+7 SET DG82=$GET(^DGPT(DG0,"M",DG1,82))
SET DGSTRING=""
+8 FOR DGLOOP=1:1:25
SET $PIECE(DGSTRING,U,DGLOOP)=$PIECE(DG82,U,DGLOOP)
+9 QUIT DGSTRING
+10 ;
