DGPTRNU1 ;ISF/GJW,HIOFO/FT - PTF TRANSMISSION UTILITY ;4/20/15 10:28am
;;5.3;Registration;**884**;Aug 13, 1993;Build 31
;
;no external references
;
DXLSONLY(DGPTF) ;no secondary diagnoses
N IENS,ROOT,MROOT,FIELDS,I,VAL
S IENS=$G(DGPTF)_","
S FIELDS="79.16;79.17;79.18;79.19;79.201;79.21;79.22;79.23;79.24;79.241;79.242;79.243;79.244;79.245;79.246;79.247;79.248;79.249;79.2491;79.24911;79.24912;79.24913;79.24914;79.24915"
D GETS^DIQ(45,IENS,FIELDS,"I","ROOT","MROOT")
S VAL=1 ;defaault to yes
F I=1:1:$L(FIELDS,";") D
.I $G(ROOT(45,IENS,$P(FIELDS,";",I),"I"))'="" S VAL=0
Q VAL
;
TDIS(DGPTF) ;type of disposition
N IENS
S IENS=DGPTF_","
Q $$GET1^DIQ(45,IENS,72,"I")
;
JUSTIFY(DGX,DGWIDTH,DGPAD,DGDIR,DGTRUNC) ;justify within a field
;DGX - the value to be justified
;DGWIDTH - width of the field
;DGPAD - pad character (defaults to space)
;DGDIR - direction of justification ("L" or "R", defaults to "L")
;DGTRUNC - should the value be truncated if it is larger than DGWIDTH Default is 1 (yes).
N PAD,I,N
S DGX=$G(DGX),DGDIR=$G(DGDIR,"L"),DGPAD=$G(DGPAD," ")
S DGPAD=$E(DGPAD,1),DGTRUNC=$G(DGTRUNC,1)
S PAD="",VAL=$G(DGX)
I $L(DGX)<DGWIDTH D
.S N=DGWIDTH-$L(DGX)
.F I=1:1:N S PAD=PAD_DGPAD
.S VAL=$S(DGDIR="L":DGX_PAD,1:PAD_DGX)
I ($L(DGX)'<DGWIDTH)&DGTRUNC S VAL=$E(VAL,1,DGWIDTH)
Q VAL
;
SPEC2PTF(DGSPEC) ;return bed/ward (PTF code) for specialty
N Y,ARRY,X
S Y=$$TSDATA^DGACT(42.4,DGSPEC,.ARRY)
S X=$S(Y'>0:"",1:$G(ARRY(7)))
S X=$$JUSTIFY(X,2,"0","R")
Q X
;
FMTMPCR(DGX) ;format MPCR code
Q $E($P(DGX,".")_"0000",1,4)_$E($P(DGX,".",2)_"00",1,2)
;
CDATA(PTF,SEG) ;control data (all segments)
N NODE ;return value
N IENS,IENS2
N DFN,SSN,PSR,FAC,SUF,ADATE,ATIME
S IENS=PTF_","
S DFN=$$GET1^DIQ(45,IENS,.01,"I"),IENS2=DFN_","
S SSN=$$GET1^DIQ(2,IENS2,.09,"I")
S PSR=$$GET1^DIQ(2,IENS2,.0906,"I") ;pseudo-SSN reason
S NODE=$G(SEG) ;transaction type
S $E(NODE,6,14)=SSN
S $E(NODE,5)=$S($L(PSR)>0:"P",1:" ")
S ADATE=$$GET1^DIQ(45,IENS,2,"I") ;admission date
S $E(NODE,15,20)=$$FDATE^DGPTRNU($P(ADATE,".")) ;format as MMDDYY
S ATIME=$$TIME^DGPTRNU(ADATE) ;admission time (HHMM)
S:ATIME'?4N ATIME="0000"
S $E(NODE,21,24)=ATIME
S FAC=$$GET1^DIQ(45,IENS,3,"I") ;facility number
S $E(NODE,25,27)=FAC ;discharge facility
S SUF=$$GET1^DIQ(45,IENS,5,"I") ;suffix
S $E(NODE,28,30)=$E(SUF_" ",1,3) ;suffix (or blank)
Q NODE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTRNU1 2441 printed Oct 16, 2024@18:54:06 Page 2
DGPTRNU1 ;ISF/GJW,HIOFO/FT - PTF TRANSMISSION UTILITY ;4/20/15 10:28am
+1 ;;5.3;Registration;**884**;Aug 13, 1993;Build 31
+2 ;
+3 ;no external references
+4 ;
DXLSONLY(DGPTF) ;no secondary diagnoses
+1 NEW IENS,ROOT,MROOT,FIELDS,I,VAL
+2 SET IENS=$GET(DGPTF)_","
+3 SET FIELDS="79.16;79.17;79.18;79.19;79.201;79.21;79.22;79.23;79.24;79.241;79.242;79.243;79.244;79.245;79.246;79.247;79.248;79.249;79.2491;79.24911;79.24912;79.24913;79.24914;79.24915"
+4 DO GETS^DIQ(45,IENS,FIELDS,"I","ROOT","MROOT")
+5 ;defaault to yes
SET VAL=1
+6 FOR I=1:1:$LENGTH(FIELDS,";")
Begin DoDot:1
+7 IF $GET(ROOT(45,IENS,$PIECE(FIELDS,";",I),"I"))'=""
SET VAL=0
End DoDot:1
+8 QUIT VAL
+9 ;
TDIS(DGPTF) ;type of disposition
+1 NEW IENS
+2 SET IENS=DGPTF_","
+3 QUIT $$GET1^DIQ(45,IENS,72,"I")
+4 ;
JUSTIFY(DGX,DGWIDTH,DGPAD,DGDIR,DGTRUNC) ;justify within a field
+1 ;DGX - the value to be justified
+2 ;DGWIDTH - width of the field
+3 ;DGPAD - pad character (defaults to space)
+4 ;DGDIR - direction of justification ("L" or "R", defaults to "L")
+5 ;DGTRUNC - should the value be truncated if it is larger than DGWIDTH Default is 1 (yes).
+6 NEW PAD,I,N
+7 SET DGX=$GET(DGX)
SET DGDIR=$GET(DGDIR,"L")
SET DGPAD=$GET(DGPAD," ")
+8 SET DGPAD=$EXTRACT(DGPAD,1)
SET DGTRUNC=$GET(DGTRUNC,1)
+9 SET PAD=""
SET VAL=$GET(DGX)
+10 IF $LENGTH(DGX)<DGWIDTH
Begin DoDot:1
+11 SET N=DGWIDTH-$LENGTH(DGX)
+12 FOR I=1:1:N
SET PAD=PAD_DGPAD
+13 SET VAL=$SELECT(DGDIR="L":DGX_PAD,1:PAD_DGX)
End DoDot:1
+14 IF ($LENGTH(DGX)'<DGWIDTH)&DGTRUNC
SET VAL=$EXTRACT(VAL,1,DGWIDTH)
+15 QUIT VAL
+16 ;
SPEC2PTF(DGSPEC) ;return bed/ward (PTF code) for specialty
+1 NEW Y,ARRY,X
+2 SET Y=$$TSDATA^DGACT(42.4,DGSPEC,.ARRY)
+3 SET X=$SELECT(Y'>0:"",1:$GET(ARRY(7)))
+4 SET X=$$JUSTIFY(X,2,"0","R")
+5 QUIT X
+6 ;
FMTMPCR(DGX) ;format MPCR code
+1 QUIT $EXTRACT($PIECE(DGX,".")_"0000",1,4)_$EXTRACT($PIECE(DGX,".",2)_"00",1,2)
+2 ;
CDATA(PTF,SEG) ;control data (all segments)
+1 ;return value
NEW NODE
+2 NEW IENS,IENS2
+3 NEW DFN,SSN,PSR,FAC,SUF,ADATE,ATIME
+4 SET IENS=PTF_","
+5 SET DFN=$$GET1^DIQ(45,IENS,.01,"I")
SET IENS2=DFN_","
+6 SET SSN=$$GET1^DIQ(2,IENS2,.09,"I")
+7 ;pseudo-SSN reason
SET PSR=$$GET1^DIQ(2,IENS2,.0906,"I")
+8 ;transaction type
SET NODE=$GET(SEG)
+9 SET $EXTRACT(NODE,6,14)=SSN
+10 SET $EXTRACT(NODE,5)=$SELECT($LENGTH(PSR)>0:"P",1:" ")
+11 ;admission date
SET ADATE=$$GET1^DIQ(45,IENS,2,"I")
+12 ;format as MMDDYY
SET $EXTRACT(NODE,15,20)=$$FDATE^DGPTRNU($PIECE(ADATE,"."))
+13 ;admission time (HHMM)
SET ATIME=$$TIME^DGPTRNU(ADATE)
+14 if ATIME'?4N
SET ATIME="0000"
+15 SET $EXTRACT(NODE,21,24)=ATIME
+16 ;facility number
SET FAC=$$GET1^DIQ(45,IENS,3,"I")
+17 ;discharge facility
SET $EXTRACT(NODE,25,27)=FAC
+18 ;suffix
SET SUF=$$GET1^DIQ(45,IENS,5,"I")
+19 ;suffix (or blank)
SET $EXTRACT(NODE,28,30)=$EXTRACT(SUF_" ",1,3)
+20 QUIT NODE
