GMTSDGP ; SLC/TRS,KER/NDBI - PTF Surgeries/Procedures ;06/25/15 15:48
;;2.7;Health Summary;**28,49,60,71,101,111**;Oct 20, 1995;Build 17
;
; External References
; ICR 5699 $$ICDDATA^ICDXCODE
; ICR 1372 ^DGPT(
; ICR 1372 ^DGPT("B"
; ICR 2929 OPC^A7RHSM
; ICR 2929 PRC^A7RHSM
;
ENS ; Module For History of PTF Surgery Episodes
I $D(GMTSNDM),GMTSNDM>0 S CNTR=GMTSNDM
E S CNTR=100
S T1=GMTSEND,T2=GMTSBEG,GMCZ=0
S PTF=0
F S PTF=$O(^DGPT("B",DFN,PTF)) Q:PTF="" D ICDS
D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) OPC^A7RHSM
I $D(GMS) S O=0 F I=1:1 S O=$O(GMS(O)) Q:O="" Q:'CNTR S CNTR=CNTR-1 S O1=0,LN1=1 F I=1:1 S O1=$O(GMS(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG LN1=1 W:LN1 GMS(O) W ?23,$P(GMS(O,O1),U),?61,$P(GMS(O,O1),U,2),! S LN1=0
D KILLADM Q
ICDS ; ICD Surgery
N GMCZ,GMA,D0,DA,DR,DIC,II,IX,SURG,ZI,GMTSDATE Q:'$D(^DGPT(PTF,"S"))
S II=0 F ZI=1:1 S II=$O(^DGPT(PTF,"S",II)) Q:'II S SURG=^DGPT(PTF,"S",II,0)_U_$G(^DGPT(PTF,"S",II,1)),X=$P(SURG,U,1),IX=9999999-X I X>T2&(X<T1) D REGDT4^GMTSU D ICDS1
Q
ICDS1 ; Load Surgery entries into GMS array (inverted)
S GMCZ=2 S GMS(IX)=" Surgery "_X F GMA=8:1:32 D SGY
Q
SGY ; Surgery Line
N ICDP,ICDI,ICDX,GMTSDATE,GMTSTEMP,GMTSTAB
S GMTSDATE=$P(^DGPT(PTF,70),U),GMTSTAB=" "
S ICDI=+$P(SURG,U,GMA) Q:ICDI'>0
S ICDX=$$CODESYS^GMTSPXU1(ICDI,80.1)
I $P($G(ICDX),U)=-1 S GMS(IX,GMA)=$J(" ",38)_$P($G(ICDX),"^",2) Q
S ICDS(80.1,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
S GMTSTEMP=$$VLT^ICDEX(80.1,ICDI,$G(GMTSDATE))
S ICDS(80.1,ICDI,4)=GMTSTEMP
I $D(ICDS(80.1,ICDI)) D
. S GMS(IX,GMA)=$G(ICDS(80.1,ICDI,4))_U_$G(ICDS(80.1,ICDI,.01))
Q
;
ENP ; Module For History of PTF Procedures
I $D(GMTSNDM),GMTSNDM>0 S CNTR=GMTSNDM
E S CNTR=100
S T1=GMTSEND,T2=GMTSBEG,GMCZ=0
S PTF=0
F S PTF=$O(^DGPT("B",DFN,PTF)) Q:PTF="" D ICDP
D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) PRC^A7RHSM
I $D(GMP) S O=0 F I=1:1 S O=$O(GMP(O)) Q:O="" Q:'CNTR S CNTR=CNTR-1 S O1=0,LN1=1 F I=1:1 S O1=$O(GMP(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG LN1=1 W:LN1 GMP(O) W ?23,$P(GMP(O,O1),U),?61,$P(GMP(O,O1),U,2),! S LN1=0
D KILLADM Q
Q
ICDP ; ICD Procedures
N D0,DA,DIC,DR,GMCZ,GTA,II,IX,PRX,ZI Q:'$D(^DGPT(PTF,"P"))
S II=0 F ZI=1:1 S II=$O(^DGPT(PTF,"P",II)) Q:'II S PRX=^DGPT(PTF,"P",II,0)_U_$G(^DGPT(PTF,"P",II,1)),X=$P(PRX,U,1),IX=9999999-X I X>T2&(X<T1) D REGDT4^GMTSU D ICDP1
Q
ICDP1 ; Load Procedure entries into GMP array (inverted)
S GMCZ=2 S GMP(IX)="Procedure "_X F GTA=5:1:29 D PXGY
Q
PXGY ; Procedure Line
N ICDP,ICDI,ICDX,GMTSDATE,GMTSTEMP,GMTSTAB
S GMTSDATE=$P(^DGPT(PTF,70),U),GMTSTAB=" "
S ICDI=+$P(PRX,U,GTA) Q:ICDI'>0
S ICDX=$$CODESYS^GMTSPXU1(ICDI,80.1)
I $P($G(ICDX),U)=-1 S GMP(IX,GTA)=$J(" ",38)_$P($G(ICDX),"^",2) Q
S ICDP(80.1,ICDI,.01)=GMTSTAB_$P(ICDX,U)_"("_$P(ICDX,U,2)_")"
S GMTSTEMP=$$VLT^ICDEX(80.1,ICDI,$G(GMTSDATE))
S ICDP(80.1,ICDI,4)=GMTSTEMP
I $D(ICDP(80.1,ICDI)) D
. S GMP(IX,GTA)=$G(ICDP(80.1,ICDI,4))_U_$G(ICDP(80.1,ICDI,.01))
Q
;
KILLADM ; Kills Admission variables
K CNTR,GMCZ,LN1,IX,X,ZA,N,ICD,ICD0,PTF,GMC,O,O1,GMS,T1,T2,SURG,SURGY,PRX,PRXY,DATE,D1,I,IMT,GMA,GTA,II,ZI,GMP
K ICDP,ICDS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGP 3243 printed Sep 23, 2025@19:33:31 Page 2
GMTSDGP ; SLC/TRS,KER/NDBI - PTF Surgeries/Procedures ;06/25/15 15:48
+1 ;;2.7;Health Summary;**28,49,60,71,101,111**;Oct 20, 1995;Build 17
+2 ;
+3 ; External References
+4 ; ICR 5699 $$ICDDATA^ICDXCODE
+5 ; ICR 1372 ^DGPT(
+6 ; ICR 1372 ^DGPT("B"
+7 ; ICR 2929 OPC^A7RHSM
+8 ; ICR 2929 PRC^A7RHSM
+9 ;
ENS ; Module For History of PTF Surgery Episodes
+1 IF $DATA(GMTSNDM)
IF GMTSNDM>0
SET CNTR=GMTSNDM
+2 IF '$TEST
SET CNTR=100
+3 SET T1=GMTSEND
SET T2=GMTSBEG
SET GMCZ=0
+4 SET PTF=0
+5 FOR
SET PTF=$ORDER(^DGPT("B",DFN,PTF))
if PTF=""
QUIT
DO ICDS
+6 if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO OPC^A7RHSM
+7 IF $DATA(GMS)
SET O=0
FOR I=1:1
SET O=$ORDER(GMS(O))
if O=""
QUIT
if 'CNTR
QUIT
SET CNTR=CNTR-1
SET O1=0
SET LN1=1
FOR I=1:1
SET O1=$ORDER(GMS(O,O1))
if O1=""
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG
SET LN1=1
if LN1
WRITE GMS(O)
WRITE ?23,$PIECE(GMS(O,O1),U),?61,$PIECE(GMS(O,O1),U,2),!
SET LN1=0
+8 DO KILLADM
QUIT
ICDS ; ICD Surgery
+1 NEW GMCZ,GMA,D0,DA,DR,DIC,II,IX,SURG,ZI,GMTSDATE
if '$DATA(^DGPT(PTF,"S"))
QUIT
+2 SET II=0
FOR ZI=1:1
SET II=$ORDER(^DGPT(PTF,"S",II))
if 'II
QUIT
SET SURG=^DGPT(PTF,"S",II,0)_U_$GET(^DGPT(PTF,"S",II,1))
SET X=$PIECE(SURG,U,1)
SET IX=9999999-X
IF X>T2&(X<T1)
DO REGDT4^GMTSU
DO ICDS1
+3 QUIT
ICDS1 ; Load Surgery entries into GMS array (inverted)
+1 SET GMCZ=2
SET GMS(IX)=" Surgery "_X
FOR GMA=8:1:32
DO SGY
+2 QUIT
SGY ; Surgery Line
+1 NEW ICDP,ICDI,ICDX,GMTSDATE,GMTSTEMP,GMTSTAB
+2 SET GMTSDATE=$PIECE(^DGPT(PTF,70),U)
SET GMTSTAB=" "
+3 SET ICDI=+$PIECE(SURG,U,GMA)
if ICDI'>0
QUIT
+4 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80.1)
+5 IF $PIECE($GET(ICDX),U)=-1
SET GMS(IX,GMA)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
QUIT
+6 SET ICDS(80.1,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+7 SET GMTSTEMP=$$VLT^ICDEX(80.1,ICDI,$GET(GMTSDATE))
+8 SET ICDS(80.1,ICDI,4)=GMTSTEMP
+9 IF $DATA(ICDS(80.1,ICDI))
Begin DoDot:1
+10 SET GMS(IX,GMA)=$GET(ICDS(80.1,ICDI,4))_U_$GET(ICDS(80.1,ICDI,.01))
End DoDot:1
+11 QUIT
+12 ;
ENP ; Module For History of PTF Procedures
+1 IF $DATA(GMTSNDM)
IF GMTSNDM>0
SET CNTR=GMTSNDM
+2 IF '$TEST
SET CNTR=100
+3 SET T1=GMTSEND
SET T2=GMTSBEG
SET GMCZ=0
+4 SET PTF=0
+5 FOR
SET PTF=$ORDER(^DGPT("B",DFN,PTF))
if PTF=""
QUIT
DO ICDP
+6 if $$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU)
DO PRC^A7RHSM
+7 IF $DATA(GMP)
SET O=0
FOR I=1:1
SET O=$ORDER(GMP(O))
if O=""
QUIT
if 'CNTR
QUIT
SET CNTR=CNTR-1
SET O1=0
SET LN1=1
FOR I=1:1
SET O1=$ORDER(GMP(O,O1))
if O1=""
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG
SET LN1=1
if LN1
WRITE GMP(O)
WRITE ?23,$PIECE(GMP(O,O1),U),?61,$PIECE(GMP(O,O1),U,2),!
SET LN1=0
+8 DO KILLADM
QUIT
+9 QUIT
ICDP ; ICD Procedures
+1 NEW D0,DA,DIC,DR,GMCZ,GTA,II,IX,PRX,ZI
if '$DATA(^DGPT(PTF,"P"))
QUIT
+2 SET II=0
FOR ZI=1:1
SET II=$ORDER(^DGPT(PTF,"P",II))
if 'II
QUIT
SET PRX=^DGPT(PTF,"P",II,0)_U_$GET(^DGPT(PTF,"P",II,1))
SET X=$PIECE(PRX,U,1)
SET IX=9999999-X
IF X>T2&(X<T1)
DO REGDT4^GMTSU
DO ICDP1
+3 QUIT
ICDP1 ; Load Procedure entries into GMP array (inverted)
+1 SET GMCZ=2
SET GMP(IX)="Procedure "_X
FOR GTA=5:1:29
DO PXGY
+2 QUIT
PXGY ; Procedure Line
+1 NEW ICDP,ICDI,ICDX,GMTSDATE,GMTSTEMP,GMTSTAB
+2 SET GMTSDATE=$PIECE(^DGPT(PTF,70),U)
SET GMTSTAB=" "
+3 SET ICDI=+$PIECE(PRX,U,GTA)
if ICDI'>0
QUIT
+4 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80.1)
+5 IF $PIECE($GET(ICDX),U)=-1
SET GMP(IX,GTA)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
QUIT
+6 SET ICDP(80.1,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
+7 SET GMTSTEMP=$$VLT^ICDEX(80.1,ICDI,$GET(GMTSDATE))
+8 SET ICDP(80.1,ICDI,4)=GMTSTEMP
+9 IF $DATA(ICDP(80.1,ICDI))
Begin DoDot:1
+10 SET GMP(IX,GTA)=$GET(ICDP(80.1,ICDI,4))_U_$GET(ICDP(80.1,ICDI,.01))
End DoDot:1
+11 QUIT
+12 ;
KILLADM ; Kills Admission variables
+1 KILL CNTR,GMCZ,LN1,IX,X,ZA,N,ICD,ICD0,PTF,GMC,O,O1,GMS,T1,T2,SURG,SURGY,PRX,PRXY,DATE,D1,I,IMT,GMA,GTA,II,ZI,GMP
+2 KILL ICDP,ICDS
+3 QUIT
