DGPTSPQ ;ALB/MTC - PTF Utility Con; 5/18/05 ; 11/26/03 9:56am
;;5.3;Registration;**195,397,565,664**;Aug 13, 1993;Build 15
;
CHQUES ;-- This function will determine if the patient has any of the
; following indicated : AO, IR, EC, MST, NTR
; If so the array DGEXQ will contain:
; DGEXQ(1)="" - AO
; DGEXQ(2)="" - IR
; DGEXQ(3)="" - SW Asia Conditions/EC
; DGEXQ(4)="" - MST ;added 6/17/98 for MST enhancement
; DGEXQ(5)="" - NTR ;treatment for Head/Neck CA
; ;ONLY if (#28.11) Nose Throat Radium entered
; DGEXQ(6)="" - CV ;treatment for possible combat related
; ;condition
; DGEXQ(7)="" - SHAD ;treatment for Project 112/SHAD
; Otherwise they will be undefined.
; This routine is called from the PTF input templates.
; The following variables are defined:
; DGHOLD : Movemnent record before any changes been made.
; DGPTF : PTF Record Number.
; DGMOV : PTF Movement Number (optional)
N DGHOLD,SDCLY
S DGHOLD=^DGPT(DA(1),"M",DA,0),SDCLY=""
;-- call to determine if questions should be asked. OPC uses same
; criteria.
D CL^SDCO21(DFN,$P(DGHOLD,U,10),"",.SDCLY)
;
;-- if sc > 50% and treated for sc don't ask AO/IR
;-- ADD KILL OF SDCLY(6) TO SKIP COMBAT VETERAN QUESTION
I $P($G(^DGPT(DGPTF,"M",+$G(DGMOV),0)),U,18)=1 K SDCLY(1),SDCLY(2)
;
G:'$D(SDCLY) CHQ
; AO
I $D(SDCLY(1)) S DGEXQ(1)=""
; IR
I $D(SDCLY(2)) S DGEXQ(2)=""
; SW Asia Conditions/EC
I $D(SDCLY(4)) S DGEXQ(3)=""
; MST
I $D(SDCLY(5)) S DGEXQ(4)="" ;added 6/17/98 for MST enhancement
; NTR
I $D(SDCLY(6)) S DGEXQ(5)=""
; CV
I $D(SDCLY(7)) S DGEXQ(6)=""
; SHAD
I $D(SDCLY(8)) S DGEXQ(7)=""
CHQ Q
;
501 ;-- This is the input transform logic for the following questions:
; AO, IR, EC, MST, NTR
; Process: Make sure that the conditions are indicated before
; allowing data to be entered. If the indicators are
; not present and the question was answered, DGER
; will be set to 1.
; INPUT : DGFLAG - Field to check
; DGER - DGER error code
N DGEXQ
S DGER=0
D CHQUES
I '$D(DGEXQ(+DGFLAG)) S DGER=1
Q
;
701 ;-- This is the input transform logic for the following questions
; for the <701> PTF record: AO, IR, EC, MST, NTR
; Process: Check if the desired indicator was answered on a <501>.
; changed 6/17/98 for MST enhancement
; INPUT DGFLAG - 1=AO, 2=IR, 3=EC, 4=MST, 5=NTR, 6=CV, 7=SHAD
N I
S DGER=1
;-- loop thru <501>'s for indicator specified by DGFLAG
S I=0 F S I=$O(^DGPT(DA,"M",I)) Q:'I I $P($G(^DGPT(DA,"M",I,0)),U,DGFLAG+25)'="" S DGER=0 Q
Q
;
UP701 ;-- This function will loop thru the <501> and determine if any
; of the SC, AO, IR, EC, MST, NTR, CV, and SHAD questions have been
; answered. If so, the cooresponding <701> will be updated.
; An answer of "yes" will take presidence.
;
; INPUT : DGPTF
; changed 6/17/98 for MST emhancement
N I,DGSC,DGAO,DGIR,DGEC,DGMOV,DGMST,DGNTR,DGCV,DGSHAD
S (DGSC,DGAO,DGIR,DGEC,DGMST,DGNTR,DGCV,DGSHAD)="@"
;-- loop thru <501>s
S I=0 F S I=$O(^DGPT(DGPTF,"M",I)) Q:'I S DGMOV=$G(^(I,0)) I DGMOV'="" D
.;-- sc
.I $P(DGMOV,U,18)'="",DGSC'=1 S DGSC=$P(DGMOV,U,18)
.;-- ao
.I $P(DGMOV,U,26)'="",DGAO'="Y" S DGAO=$P(DGMOV,U,26)
.;-- ir
.I $P(DGMOV,U,27)'="",DGIR'="Y" S DGIR=$P(DGMOV,U,27)
.;-- ec
.I $P(DGMOV,U,28)'="",DGEC'="Y" S DGEC=$P(DGMOV,U,28)
.;-- mst ;added 6/17/98 for MST enhancement
.I $P(DGMOV,U,29)'="",DGMST'="Y" S DGMST=$P(DGMOV,U,29)
.;-- ntr
.I $P(DGMOV,U,30)'="",DGNTR'="Y" S DGNTR=$P(DGMOV,U,30)
.;-- cv
.I $P(DGMOV,U,31)'="",DGCV'="Y" S DGCV=$P(DGMOV,U,31)
.;-- shad
.I $P(DGMOV,U,32)'="",DGSHAD'="Y" S DGSHAD=$P(DGMOV,U,32)
;-- update <701> fields
; changed 6/17/98 for MST enhancement
S DR="79.25////^S X=DGSC;79.26////^S X=DGAO;79.27////^S X=DGIR;79.28////^S X=DGEC;79.29////^S X=DGMST;79.3////^S X=DGNTR;79.31////^S X=DGCV;79.32////^S X=DGSHAD"
S DA=DGPTF,DIE="^DGPT("
D ^DIE K DIE,DA,DR
UPQ Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTSPQ 4113 printed Sep 23, 2025@20:29:30 Page 2
DGPTSPQ ;ALB/MTC - PTF Utility Con; 5/18/05 ; 11/26/03 9:56am
+1 ;;5.3;Registration;**195,397,565,664**;Aug 13, 1993;Build 15
+2 ;
CHQUES ;-- This function will determine if the patient has any of the
+1 ; following indicated : AO, IR, EC, MST, NTR
+2 ; If so the array DGEXQ will contain:
+3 ; DGEXQ(1)="" - AO
+4 ; DGEXQ(2)="" - IR
+5 ; DGEXQ(3)="" - SW Asia Conditions/EC
+6 ; DGEXQ(4)="" - MST ;added 6/17/98 for MST enhancement
+7 ; DGEXQ(5)="" - NTR ;treatment for Head/Neck CA
+8 ; ;ONLY if (#28.11) Nose Throat Radium entered
+9 ; DGEXQ(6)="" - CV ;treatment for possible combat related
+10 ; ;condition
+11 ; DGEXQ(7)="" - SHAD ;treatment for Project 112/SHAD
+12 ; Otherwise they will be undefined.
+13 ; This routine is called from the PTF input templates.
+14 ; The following variables are defined:
+15 ; DGHOLD : Movemnent record before any changes been made.
+16 ; DGPTF : PTF Record Number.
+17 ; DGMOV : PTF Movement Number (optional)
+18 NEW DGHOLD,SDCLY
+19 SET DGHOLD=^DGPT(DA(1),"M",DA,0)
SET SDCLY=""
+20 ;-- call to determine if questions should be asked. OPC uses same
+21 ; criteria.
+22 DO CL^SDCO21(DFN,$PIECE(DGHOLD,U,10),"",.SDCLY)
+23 ;
+24 ;-- if sc > 50% and treated for sc don't ask AO/IR
+25 ;-- ADD KILL OF SDCLY(6) TO SKIP COMBAT VETERAN QUESTION
+26 IF $PIECE($GET(^DGPT(DGPTF,"M",+$GET(DGMOV),0)),U,18)=1
KILL SDCLY(1),SDCLY(2)
+27 ;
+28 if '$DATA(SDCLY)
GOTO CHQ
+29 ; AO
+30 IF $DATA(SDCLY(1))
SET DGEXQ(1)=""
+31 ; IR
+32 IF $DATA(SDCLY(2))
SET DGEXQ(2)=""
+33 ; SW Asia Conditions/EC
+34 IF $DATA(SDCLY(4))
SET DGEXQ(3)=""
+35 ; MST
+36 ;added 6/17/98 for MST enhancement
IF $DATA(SDCLY(5))
SET DGEXQ(4)=""
+37 ; NTR
+38 IF $DATA(SDCLY(6))
SET DGEXQ(5)=""
+39 ; CV
+40 IF $DATA(SDCLY(7))
SET DGEXQ(6)=""
+41 ; SHAD
+42 IF $DATA(SDCLY(8))
SET DGEXQ(7)=""
CHQ QUIT
+1 ;
501 ;-- This is the input transform logic for the following questions:
+1 ; AO, IR, EC, MST, NTR
+2 ; Process: Make sure that the conditions are indicated before
+3 ; allowing data to be entered. If the indicators are
+4 ; not present and the question was answered, DGER
+5 ; will be set to 1.
+6 ; INPUT : DGFLAG - Field to check
+7 ; DGER - DGER error code
+8 NEW DGEXQ
+9 SET DGER=0
+10 DO CHQUES
+11 IF '$DATA(DGEXQ(+DGFLAG))
SET DGER=1
+12 QUIT
+13 ;
701 ;-- This is the input transform logic for the following questions
+1 ; for the <701> PTF record: AO, IR, EC, MST, NTR
+2 ; Process: Check if the desired indicator was answered on a <501>.
+3 ; changed 6/17/98 for MST enhancement
+4 ; INPUT DGFLAG - 1=AO, 2=IR, 3=EC, 4=MST, 5=NTR, 6=CV, 7=SHAD
+5 NEW I
+6 SET DGER=1
+7 ;-- loop thru <501>'s for indicator specified by DGFLAG
+8 SET I=0
FOR
SET I=$ORDER(^DGPT(DA,"M",I))
if 'I
QUIT
IF $PIECE($GET(^DGPT(DA,"M",I,0)),U,DGFLAG+25)'=""
SET DGER=0
QUIT
+9 QUIT
+10 ;
UP701 ;-- This function will loop thru the <501> and determine if any
+1 ; of the SC, AO, IR, EC, MST, NTR, CV, and SHAD questions have been
+2 ; answered. If so, the cooresponding <701> will be updated.
+3 ; An answer of "yes" will take presidence.
+4 ;
+5 ; INPUT : DGPTF
+6 ; changed 6/17/98 for MST emhancement
+7 NEW I,DGSC,DGAO,DGIR,DGEC,DGMOV,DGMST,DGNTR,DGCV,DGSHAD
+8 SET (DGSC,DGAO,DGIR,DGEC,DGMST,DGNTR,DGCV,DGSHAD)="@"
+9 ;-- loop thru <501>s
+10 SET I=0
FOR
SET I=$ORDER(^DGPT(DGPTF,"M",I))
if 'I
QUIT
SET DGMOV=$GET(^(I,0))
IF DGMOV'=""
Begin DoDot:1
+11 ;-- sc
+12 IF $PIECE(DGMOV,U,18)'=""
IF DGSC'=1
SET DGSC=$PIECE(DGMOV,U,18)
+13 ;-- ao
+14 IF $PIECE(DGMOV,U,26)'=""
IF DGAO'="Y"
SET DGAO=$PIECE(DGMOV,U,26)
+15 ;-- ir
+16 IF $PIECE(DGMOV,U,27)'=""
IF DGIR'="Y"
SET DGIR=$PIECE(DGMOV,U,27)
+17 ;-- ec
+18 IF $PIECE(DGMOV,U,28)'=""
IF DGEC'="Y"
SET DGEC=$PIECE(DGMOV,U,28)
+19 ;-- mst ;added 6/17/98 for MST enhancement
+20 IF $PIECE(DGMOV,U,29)'=""
IF DGMST'="Y"
SET DGMST=$PIECE(DGMOV,U,29)
+21 ;-- ntr
+22 IF $PIECE(DGMOV,U,30)'=""
IF DGNTR'="Y"
SET DGNTR=$PIECE(DGMOV,U,30)
+23 ;-- cv
+24 IF $PIECE(DGMOV,U,31)'=""
IF DGCV'="Y"
SET DGCV=$PIECE(DGMOV,U,31)
+25 ;-- shad
+26 IF $PIECE(DGMOV,U,32)'=""
IF DGSHAD'="Y"
SET DGSHAD=$PIECE(DGMOV,U,32)
End DoDot:1
+27 ;-- update <701> fields
+28 ; changed 6/17/98 for MST enhancement
+29 SET DR="79.25////^S X=DGSC;79.26////^S X=DGAO;79.27////^S X=DGIR;79.28////^S X=DGEC;79.29////^S X=DGMST;79.3////^S X=DGNTR;79.31////^S X=DGCV;79.32////^S X=DGSHAD"
+30 SET DA=DGPTF
SET DIE="^DGPT("
+31 DO ^DIE
KILL DIE,DA,DR
UPQ QUIT
+1 ;
