- GMTSDGC2 ; SLC/SBW,KER - Extended ADT Hist (cont) ;06/25/15 15:48
- ;;2.7;Health Summary;**28,49,71,101,111**;Oct 20, 1995;Build 17
- ;
- ; External References
- ; ICR 1372 ^DGPT(
- ; ICR 5699 $$ICDDATA^ICDXCODE
- ;
- ICDP(DFN,PTF) ; Module For History of PTF Procedures
- Q:'$D(^DGPT(PTF,"P"))
- N II,PRX,X,IX,GMP,GTA,O,O1,LN1,GMTSTAB
- S II=0,GMTSTAB=" "
- F 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 D REGDT4^GMTSU D
- . N GMTSDATE,GMTSTEMP S GMTSDATE=$P(^DGPT(PTF,70),U)
- . S GMP(IX)="Procedure "_X F GTA=5:1:30 D
- . . N ICDP,ICDI,ICDX Q:$P(PRX,U,GTA)=""
- . . 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)=ICDP(80.1,ICDI,4)_U_ICDP(80.1,ICDI,.01)
- I $D(GMP) S O=0 F S O=$O(GMP(O)) Q:O="" D
- . S O1=0,LN1=1
- . F S O1=$O(GMP(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG LN1=1 W:LN1 ?2,GMP(O) W ?23,$P(GMP(O,O1),U),?61,$P(GMP(O,O1),U,2),! S LN1=0
- Q
- ICDS(DFN,PTF) ; Module for history of PTF surgery episodes
- Q:'$D(^DGPT(PTF,"S"))
- N II,SURG,X,IX,GMS,GMA,O,O1,LN1,GMTSTAB
- S II=0,GMTSTAB=" "
- F 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 D REGDT4^GMTSU D
- . N GMTSDATE,GMTSTEMP S GMTSDATE=$P(^DGPT(PTF,70),U)
- . ; Load Surgery entries into GMS array in inverted sequence
- . S GMS(IX)=" Surgery "_X F GMA=8:1:32 D
- . . ; Surgery Line
- . . N ICDS,ICDI,ICDX
- . . 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),U,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)) S GMS(IX,GMA)=ICDS(80.1,ICDI,4)_U_ICDS(80.1,ICDI,.01)
- I $D(GMS) S O=0 F S O=$O(GMS(O)) Q:O="" D
- . S O1=0,LN1=1
- . F S O1=$O(GMS(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG LN1=1 W:LN1 ?2,GMS(O) W ?23,$P(GMS(O,O1),U),?61,$P(GMS(O,O1),U,2),! S LN1=0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGC2 2367 printed Mar 13, 2025@21:02:01 Page 2
- GMTSDGC2 ; SLC/SBW,KER - Extended ADT Hist (cont) ;06/25/15 15:48
- +1 ;;2.7;Health Summary;**28,49,71,101,111**;Oct 20, 1995;Build 17
- +2 ;
- +3 ; External References
- +4 ; ICR 1372 ^DGPT(
- +5 ; ICR 5699 $$ICDDATA^ICDXCODE
- +6 ;
- ICDP(DFN,PTF) ; Module For History of PTF Procedures
- +1 if '$DATA(^DGPT(PTF,"P"))
- QUIT
- +2 NEW II,PRX,X,IX,GMP,GTA,O,O1,LN1,GMTSTAB
- +3 SET II=0
- SET GMTSTAB=" "
- +4 FOR
- 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
- DO REGDT4^GMTSU
- Begin DoDot:1
- +5 NEW GMTSDATE,GMTSTEMP
- SET GMTSDATE=$PIECE(^DGPT(PTF,70),U)
- +6 SET GMP(IX)="Procedure "_X
- FOR GTA=5:1:30
- Begin DoDot:2
- +7 NEW ICDP,ICDI,ICDX
- if $PIECE(PRX,U,GTA)=""
- QUIT
- +8 SET ICDI=+($PIECE(PRX,U,GTA))
- if +ICDI'>0
- QUIT
- +9 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80.1)
- +10 IF $PIECE($GET(ICDX),U)=-1
- SET GMP(IX,GTA)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),"^",2)
- QUIT
- +11 SET ICDP(80.1,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
- +12 SET GMTSTEMP=$$VLT^ICDEX(80.1,ICDI,$GET(GMTSDATE))
- +13 SET ICDP(80.1,ICDI,4)=GMTSTEMP
- +14 IF $DATA(ICDP(80.1,ICDI))
- Begin DoDot:3
- +15 SET GMP(IX,GTA)=ICDP(80.1,ICDI,4)_U_ICDP(80.1,ICDI,.01)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 IF $DATA(GMP)
- SET O=0
- FOR
- SET O=$ORDER(GMP(O))
- if O=""
- QUIT
- Begin DoDot:1
- +17 SET O1=0
- SET LN1=1
- +18 FOR
- SET O1=$ORDER(GMP(O,O1))
- if O1=""
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMTSNPG
- SET LN1=1
- if LN1
- WRITE ?2,GMP(O)
- WRITE ?23,$PIECE(GMP(O,O1),U),?61,$PIECE(GMP(O,O1),U,2),!
- SET LN1=0
- End DoDot:1
- +19 QUIT
- ICDS(DFN,PTF) ; Module for history of PTF surgery episodes
- +1 if '$DATA(^DGPT(PTF,"S"))
- QUIT
- +2 NEW II,SURG,X,IX,GMS,GMA,O,O1,LN1,GMTSTAB
- +3 SET II=0
- SET GMTSTAB=" "
- +4 FOR
- 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
- DO REGDT4^GMTSU
- Begin DoDot:1
- +5 NEW GMTSDATE,GMTSTEMP
- SET GMTSDATE=$PIECE(^DGPT(PTF,70),U)
- +6 ; Load Surgery entries into GMS array in inverted sequence
- +7 SET GMS(IX)=" Surgery "_X
- FOR GMA=8:1:32
- Begin DoDot:2
- +8 ; Surgery Line
- +9 NEW ICDS,ICDI,ICDX
- +10 SET ICDI=+($PIECE(SURG,U,GMA))
- if +ICDI'>0
- QUIT
- +11 SET ICDX=$$CODESYS^GMTSPXU1(ICDI,80.1)
- +12 IF $PIECE($GET(ICDX),U)=-1
- SET GMS(IX,GMA)=$JUSTIFY(" ",38)_$PIECE($GET(ICDX),U,2)
- QUIT
- +13 SET ICDS(80.1,ICDI,.01)=GMTSTAB_$PIECE(ICDX,U)_"("_$PIECE(ICDX,U,2)_")"
- +14 SET GMTSTEMP=$$VLT^ICDEX(80.1,ICDI,$GET(GMTSDATE))
- +15 SET ICDS(80.1,ICDI,4)=GMTSTEMP
- +16 IF $DATA(ICDS(80.1,ICDI))
- SET GMS(IX,GMA)=ICDS(80.1,ICDI,4)_U_ICDS(80.1,ICDI,.01)
- End DoDot:2
- End DoDot:1
- +17 IF $DATA(GMS)
- SET O=0
- FOR
- SET O=$ORDER(GMS(O))
- if O=""
- QUIT
- Begin DoDot:1
- +18 SET O1=0
- SET LN1=1
- +19 FOR
- SET O1=$ORDER(GMS(O,O1))
- if O1=""
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMTSNPG
- SET LN1=1
- if LN1
- WRITE ?2,GMS(O)
- WRITE ?23,$PIECE(GMS(O,O1),U),?61,$PIECE(GMS(O,O1),U,2),!
- SET LN1=0
- End DoDot:1
- +20 QUIT
