GMPLNTFT ;ISL/JER - Freetext Problem Follow-up Report ;07/09/12 11:45
;;2.0;Problem List;**36**;Aug 25, 1994;Build 65
;
; ICR #2055 - $$EXTERNAL^DILFD
; #2056 - $$GET1^DIQ
; #3799 - $$FMTE^XLFDT
; #4558 - $$LEAP^XLFDT3
; #4631 - $$NOW^XLFDT
; #10000 - %, %I, %T, %Y Local vars
; #10063 - ^%ZTLOAD
; #10086 - ^%ZIS Routine & IO, IOF, ION, IOSL, & IOST Local Vars
; #10089 - ^%ZISC Routine & IO("Q") Local Var
; #10104 - $$LOW^XLFSTR, $$UP^XLFSTR
; #10112 - $$NAME^VASITE, $$SITE^VASITE
; #10114 - %ZIS Local Var
;
MAIN ; Main subroutine
N DIC,DIRUT,BADDIV,SELDIV,GMPLEDT,GMPLLDT,GMPLDI,VAUTD,ZTRTN,%I,%T,%Y,POP,GMPL1PR,GMPLPR,GMPLPCOM
S GMPLPR=0
W !!,$$CENTER^GMPLUTL1("--- Problem List Freetext Follow-up Report ---"),!
D SELDIV^GMPLNTRT(.GMPLDI) Q:'$D(GMPLDI)!$D(DIRUT)
W !
S GMPL1PR=$$READ^GMPLUTL1("YA","Specific Provider(s)? ","NO","Indicate whether you would like to run the report for one or more specific Providers.")
I $D(DIRUT) Q
I +GMPL1PR D PROVSEL^GMPLNTRT(.GMPLPR) Q:'+$G(GMPLPR)!+$G(DIROUT)
W !
S GMPLPCOM=$$READ^GMPLUTL1("YA","Print Comments? ","YES","Indicate whether you would like to see the users' comments for New Term Requests.")
I $D(DIRUT) Q
W !
S GMPLEDT=+$$EDATE^GMPLUTL1("Modification","","T-30")
W !
I GMPLEDT'>0 Q
S GMPLLDT=+$$LDATE^GMPLUTL1("Modification","","NOW")
W !
I GMPLLDT'>0 Q
S ZTRTN="ENTRY^GMPLNTFT"
DEVICE ; Device handling
; Call with: ZTRTN
N %ZIS
S %ZIS="Q" D ^%ZIS Q:POP
G:$D(IO("Q")) QUE
NOQUE ; Call report directly
D @ZTRTN
Q
QUE ; Queue output
N %,ZTDTH,ZTIO,ZTSAVE,ZTSK
Q:'$D(ZTRTN)
K IO("Q") F %="DA","DFN","GMPL*" S ZTSAVE(%)=""
S:'$D(ZTDESC) ZTDESC="PRINT NTRT FOLLOW-UP REPORT" S ZTIO=ION
D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
D HOME^%ZIS
Q
;
ENTRY ; Build & Print Report
N GMPLA
S GMPLA=$NA(^TMP("GMPLNTRT",$J))
U IO
D GATHER(.GMPLDI,GMPLA,GMPLEDT,GMPLLDT,.GMPLPR)
D REPORT(GMPLA,GMPLEDT,GMPLLDT,GMPLPCOM)
K @GMPLA
D ^%ZISC
Q
GATHER(GMPLDI,GMPLA,GMPLEDT,GMPLLDT,GMPLPR) ; Gather records that satisfy criteria
N GMPLDA,GMPLNOS,GMPLPOP K @GMPLA
S GMPLNOS=+$$NOS^GMPLX,GMPLDA="",GMPLPOP=0
; Insure inclusive early date/time by subtracting one minute before $ORDER
;S GMPLTDT=$$FMADD^XLFDT(GMPLEDT,0,0,-1)
; Insure inclusive end date/time by appending time of 23:59 if time not indicated
I $L(GMPLLDT,".")=1 S $P(GMPLLDT,".",2)="2359"
F S GMPLDA=$O(^AUPNPROB("B",GMPLNOS,GMPLDA),-1) Q:+GMPLPOP!(+GMPLDA'>0) D
. N GMPLD0,GMPLD1,GMPLD800,GMPLD8015,GMPLDIV,GMPLMDT,GMPLRPR,GMPLPTNM,GMPLPTL4,GMPLNARR
. N GMPLSVC,GMPLSVCA,GMPLSVCN,GMPLCL,GMPLCLA,GMPLCLN,GMPLNTRT,GMPLNTC
. S GMPLD0=$G(^AUPNPROB(GMPLDA,0)),GMPLD1=$G(^(1)),GMPLD800=$G(^(800)),GMPLD801=$G(^(801))
. ; Filter problems with unmapped SCT Concepts
. Q:+GMPLD800>0
. S GMPLMDT=$P(GMPLD0,U,3)
. I GMPLMDT<GMPLEDT S GMPLPOP=1 Q
. I GMPLMDT>GMPLLDT Q
. S GMPLRPR=$P(GMPLD1,U,5),GMPLDIV=$P(GMPLD0,U,6),GMPLPTNM=$P(GMPLD0,U,2)
. I +$G(GMPLPR),'$D(GMPLPR("I",+GMPLRPR)) Q
. I $S(GMPLDI("ENTRIES")="ALL DIVISIONS":0,$D(GMPLDI("INST",+GMPLDIV)):0,1:1) Q
. S GMPLSVC=$P(GMPLD1,U,6),GMPLCL=$P(GMPLD1,U,8)
. S GMPLSVCA=$S(GMPLSVC]"":$E($$GET1^DIQ(49,GMPLSVC,1),1,6),1:"n/a")
. S GMPLSVCN=$S(GMPLSVC]"":$E($$GET1^DIQ(49,GMPLSVC,.01),1,6),1:"n/a")
. S GMPLSVCA=$S(GMPLSVCA]"":GMPLSVCA,1:GMPLSVCN)
. S GMPLCLA=$S(GMPLCL]"":$E($$GET1^DIQ(44,GMPLCL,1),1,6),1:"n/a")
. S GMPLCLN=$S(GMPLCL]"":$E($$GET1^DIQ(44,GMPLCL,.01),1,6),1:"n/a")
. S GMPLCLA=$S(GMPLCLA]"":GMPLCLA,1:GMPLCLN)
. S GMPLDIV=$S(GMPLDIV]"":$$EXTERNAL^DILFD(9000011,.06,"",GMPLDIV),1:"DIVISION UNKNOWN")
. S GMPLRPR=$S(GMPLRPR]"":$$EXTERNAL^DILFD(9000011,1.05,"",GMPLRPR),1:"n/a")
. S GMPLNARR=$$EXTERNAL^DILFD(9000011,.05,"",$P(GMPLD0,U,5))
. S GMPLPTL4=$E($$GET1^DIQ(2,$P(GMPLD0,U,2),.09),6,9) S:GMPLPTL4']"" GMPLPTL4="UNKN"
. S GMPLPTNM=$$EXTERNAL^DILFD(9000011,.02,"",$P(GMPLD0,U,2))_"|"_GMPLPTL4
. S GMPLNTRT=$S(+$P(GMPLD801,U):"True",1:"False"),GMPLNTC=$P(GMPLD801,U,2)
. S @GMPLA@(GMPLDIV,GMPLRPR,GMPLPTNM,GMPLMDT,GMPLDA)=GMPLNARR_U_GMPLSVCA_U_GMPLCLA_U_GMPLNTRT_U_GMPLNTC
Q
REPORT(GMPLA,GMPLEDT,GMPLLDT,GMPLPCOM) ; Generate report
N GMPLDIV,GMPLRTM,DIRUT,DTOUT,DUOUT,GMPLSITE,GMPLCAT,GMPLI,GMPLPG
N GMPLSHDR,EQLN S $P(EQLN,"-",11)="",GMPLPG=0,GMPLPCOM=+$G(GMPLPCOM)
I $D(ZTQUEUED) S ZTREQ="@" ; Tell TaskMan to delete Task log entry
U IO
S GMPLRTM=$$NOW^XLFDT,GMPLSITE=$S($$NAME^VASITE]"":$$NAME^VASITE,1:$P($$SITE^VASITE,U,2))
I '$D(@GMPLA) D Q
. D HEADER("",GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
. W:$$CONTINUE("",GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG) !
. W:$$CONTINUE("",GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG) "No Freetext Problems found for selected parameters...",!
. I ($E(IOST)="C"),($E(IOSL,1,3)'=999) S:'+$$STOP^GMPLUTL1("",1) DIRUT=1
S GMPLDIV=0
F S GMPLDIV=$O(@GMPLA@(GMPLDIV)) Q:GMPLDIV']"" D Q:$D(DIRUT)
. N GMPLRPR S GMPLRPR=""
. D HEADER(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
. F S GMPLRPR=$O(@GMPLA@(GMPLDIV,GMPLRPR)) Q:GMPLRPR']"" D Q:$D(DIRUT)
. . N GMPLPT S GMPLPT=0
. . F S GMPLPT=$O(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT)) Q:GMPLPT']"" D Q:$D(DIRUT)
. . . N GMPLMDT S GMPLMDT=0
. . . F S GMPLMDT=$O(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT)) Q:+GMPLMDT'>0 D Q:$D(DIRUT)
. . . . N GMPLDA S GMPLDA=0
. . . . F S GMPLDA=$O(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT,GMPLDA)) Q:+GMPLDA'>0 D Q:$D(DIRUT)
. . . . . N GMPLD,GMPLNARR,GMPLPRNM,GMPLPTNM,GMPLSVC,GMPLCLOC,GMPLNTRT,GMPLNTC
. . . . . S GMPLD=$G(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT,GMPLDA))
. . . . . S GMPLNARR=$P(GMPLD,U),GMPLSVC=$P(GMPLD,U,2),GMPLCLOC=$P(GMPLD,U,3),GMPLNTRT=$P(GMPLD,U,4),GMPLNTC=$P(GMPLD,U,5)
. . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . W $E($$NAME^GMPLUTL1(GMPLRPR,"LAST"),1,10),$$NAME^GMPLUTL1(GMPLRPR,",FI MI")
. . . . . W ?16,$E($$NAME^GMPLUTL1($P(GMPLPT,"|"),"LAST"),1,10),$$NAME^GMPLUTL1($P(GMPLPT,"|"),",FI MI"),?31," (",$P(GMPLPT,"|",2),")"
. . . . . W ?40,$$DATE^GMPLUTL1(GMPLMDT,"MM/DD/YY"),?50,GMPLSVC,?58,GMPLCLOC,?70,GMPLNTRT,!
. . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . W ?2,GMPLNARR,!
. . . . . Q:$D(DIRUT)
. . . . . I GMPLPCOM,(GMPLNTC]"") D
. . . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . . W "Comments: ",!
. . . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . . W GMPLNTC,!
. . . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . . W !
. . . . . E Q:(+$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0)!$D(DIRUT) W !
. Q:$D(DIRUT)
. I ($E(IOST)="C"),($E(IOSL,1,3)'=999) S:'+$$STOP^GMPLUTL1("",1) DIRUT=1
Q
CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,GMPLPG) ; Evaluate relative page position
N GMPLY S GMPLY=1
I $Y'>(IOSL-3) G CONTX
I $E(IOST)="C" S GMPLY=+$$READ^GMPLUTL1("E") S:$D(DIRUT) GMPLY=0
I GMPLY'>0 G CONTX
D HEADER(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
CONTX Q GMPLY
N GMPLLINE,GMPLDTR S $P(GMPLLINE,"=",81)="",GMPLDTR=$$DATE^GMPLUTL1(GMPLEDT,"MM/DD/CCYY")_" to "_$$DATE^GMPLUTL1(GMPLLDT,"MM/DD/CCYY")
S GMPLPG=GMPLPG+1
W @IOF D JUSTIFY^GMPLUTL1("Page "_GMPLPG,"R") W !
W GMPLLINE,! D JUSTIFY^GMPLUTL1($$TITLE^GMPLUTL1("PROBLEM LIST FREETEXT FOLLOW-UP REPORT"),"C") W !
D JUSTIFY^GMPLUTL1(DIVISION,"C")
W !
W "for Problems Modified: ",GMPLDTR,?55,"Printed: ",$$DATE^GMPLUTL1(GMPLRTM,"MM/DD/CCYY HR:MIN"),!
W !
W "Provider",?16,"Patient",?40,"Modified",?50,"Service",?58,"Clinic",?70,"NTRT",!
W ?2,"Narrative",?70,"Requested",!
W GMPLLINE,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLNTFT 7877 printed Sep 23, 2025@20:06:21 Page 2
GMPLNTFT ;ISL/JER - Freetext Problem Follow-up Report ;07/09/12 11:45
+1 ;;2.0;Problem List;**36**;Aug 25, 1994;Build 65
+2 ;
+3 ; ICR #2055 - $$EXTERNAL^DILFD
+4 ; #2056 - $$GET1^DIQ
+5 ; #3799 - $$FMTE^XLFDT
+6 ; #4558 - $$LEAP^XLFDT3
+7 ; #4631 - $$NOW^XLFDT
+8 ; #10000 - %, %I, %T, %Y Local vars
+9 ; #10063 - ^%ZTLOAD
+10 ; #10086 - ^%ZIS Routine & IO, IOF, ION, IOSL, & IOST Local Vars
+11 ; #10089 - ^%ZISC Routine & IO("Q") Local Var
+12 ; #10104 - $$LOW^XLFSTR, $$UP^XLFSTR
+13 ; #10112 - $$NAME^VASITE, $$SITE^VASITE
+14 ; #10114 - %ZIS Local Var
+15 ;
MAIN ; Main subroutine
+1 NEW DIC,DIRUT,BADDIV,SELDIV,GMPLEDT,GMPLLDT,GMPLDI,VAUTD,ZTRTN,%I,%T,%Y,POP,GMPL1PR,GMPLPR,GMPLPCOM
+2 SET GMPLPR=0
+3 WRITE !!,$$CENTER^GMPLUTL1("--- Problem List Freetext Follow-up Report ---"),!
+4 DO SELDIV^GMPLNTRT(.GMPLDI)
if '$DATA(GMPLDI)!$DATA(DIRUT)
QUIT
+5 WRITE !
+6 SET GMPL1PR=$$READ^GMPLUTL1("YA","Specific Provider(s)? ","NO","Indicate whether you would like to run the report for one or more specific Providers.")
+7 IF $DATA(DIRUT)
QUIT
+8 IF +GMPL1PR
DO PROVSEL^GMPLNTRT(.GMPLPR)
if '+$GET(GMPLPR)!+$GET(DIROUT)
QUIT
+9 WRITE !
+10 SET GMPLPCOM=$$READ^GMPLUTL1("YA","Print Comments? ","YES","Indicate whether you would like to see the users' comments for New Term Requests.")
+11 IF $DATA(DIRUT)
QUIT
+12 WRITE !
+13 SET GMPLEDT=+$$EDATE^GMPLUTL1("Modification","","T-30")
+14 WRITE !
+15 IF GMPLEDT'>0
QUIT
+16 SET GMPLLDT=+$$LDATE^GMPLUTL1("Modification","","NOW")
+17 WRITE !
+18 IF GMPLLDT'>0
QUIT
+19 SET ZTRTN="ENTRY^GMPLNTFT"
DEVICE ; Device handling
+1 ; Call with: ZTRTN
+2 NEW %ZIS
+3 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+4 if $DATA(IO("Q"))
GOTO QUE
NOQUE ; Call report directly
+1 DO @ZTRTN
+2 QUIT
QUE ; Queue output
+1 NEW %,ZTDTH,ZTIO,ZTSAVE,ZTSK
+2 if '$DATA(ZTRTN)
QUIT
+3 KILL IO("Q")
FOR %="DA","DFN","GMPL*"
SET ZTSAVE(%)=""
+4 if '$DATA(ZTDESC)
SET ZTDESC="PRINT NTRT FOLLOW-UP REPORT"
SET ZTIO=ION
+5 DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled!")
+6 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+7 DO HOME^%ZIS
+8 QUIT
+9 ;
ENTRY ; Build & Print Report
+1 NEW GMPLA
+2 SET GMPLA=$NAME(^TMP("GMPLNTRT",$JOB))
+3 USE IO
+4 DO GATHER(.GMPLDI,GMPLA,GMPLEDT,GMPLLDT,.GMPLPR)
+5 DO REPORT(GMPLA,GMPLEDT,GMPLLDT,GMPLPCOM)
+6 KILL @GMPLA
+7 DO ^%ZISC
+8 QUIT
GATHER(GMPLDI,GMPLA,GMPLEDT,GMPLLDT,GMPLPR) ; Gather records that satisfy criteria
+1 NEW GMPLDA,GMPLNOS,GMPLPOP
KILL @GMPLA
+2 SET GMPLNOS=+$$NOS^GMPLX
SET GMPLDA=""
SET GMPLPOP=0
+3 ; Insure inclusive early date/time by subtracting one minute before $ORDER
+4 ;S GMPLTDT=$$FMADD^XLFDT(GMPLEDT,0,0,-1)
+5 ; Insure inclusive end date/time by appending time of 23:59 if time not indicated
+6 IF $LENGTH(GMPLLDT,".")=1
SET $PIECE(GMPLLDT,".",2)="2359"
+7 FOR
SET GMPLDA=$ORDER(^AUPNPROB("B",GMPLNOS,GMPLDA),-1)
if +GMPLPOP!(+GMPLDA'>0)
QUIT
Begin DoDot:1
+8 NEW GMPLD0,GMPLD1,GMPLD800,GMPLD8015,GMPLDIV,GMPLMDT,GMPLRPR,GMPLPTNM,GMPLPTL4,GMPLNARR
+9 NEW GMPLSVC,GMPLSVCA,GMPLSVCN,GMPLCL,GMPLCLA,GMPLCLN,GMPLNTRT,GMPLNTC
+10 SET GMPLD0=$GET(^AUPNPROB(GMPLDA,0))
SET GMPLD1=$GET(^(1))
SET GMPLD800=$GET(^(800))
SET GMPLD801=$GET(^(801))
+11 ; Filter problems with unmapped SCT Concepts
+12 if +GMPLD800>0
QUIT
+13 SET GMPLMDT=$PIECE(GMPLD0,U,3)
+14 IF GMPLMDT<GMPLEDT
SET GMPLPOP=1
QUIT
+15 IF GMPLMDT>GMPLLDT
QUIT
+16 SET GMPLRPR=$PIECE(GMPLD1,U,5)
SET GMPLDIV=$PIECE(GMPLD0,U,6)
SET GMPLPTNM=$PIECE(GMPLD0,U,2)
+17 IF +$GET(GMPLPR)
IF '$DATA(GMPLPR("I",+GMPLRPR))
QUIT
+18 IF $SELECT(GMPLDI("ENTRIES")="ALL DIVISIONS":0,$DATA(GMPLDI("INST",+GMPLDIV)):0,1:1)
QUIT
+19 SET GMPLSVC=$PIECE(GMPLD1,U,6)
SET GMPLCL=$PIECE(GMPLD1,U,8)
+20 SET GMPLSVCA=$SELECT(GMPLSVC]"":$EXTRACT($$GET1^DIQ(49,GMPLSVC,1),1,6),1:"n/a")
+21 SET GMPLSVCN=$SELECT(GMPLSVC]"":$EXTRACT($$GET1^DIQ(49,GMPLSVC,.01),1,6),1:"n/a")
+22 SET GMPLSVCA=$SELECT(GMPLSVCA]"":GMPLSVCA,1:GMPLSVCN)
+23 SET GMPLCLA=$SELECT(GMPLCL]"":$EXTRACT($$GET1^DIQ(44,GMPLCL,1),1,6),1:"n/a")
+24 SET GMPLCLN=$SELECT(GMPLCL]"":$EXTRACT($$GET1^DIQ(44,GMPLCL,.01),1,6),1:"n/a")
+25 SET GMPLCLA=$SELECT(GMPLCLA]"":GMPLCLA,1:GMPLCLN)
+26 SET GMPLDIV=$SELECT(GMPLDIV]"":$$EXTERNAL^DILFD(9000011,.06,"",GMPLDIV),1:"DIVISION UNKNOWN")
+27 SET GMPLRPR=$SELECT(GMPLRPR]"":$$EXTERNAL^DILFD(9000011,1.05,"",GMPLRPR),1:"n/a")
+28 SET GMPLNARR=$$EXTERNAL^DILFD(9000011,.05,"",$PIECE(GMPLD0,U,5))
+29 SET GMPLPTL4=$EXTRACT($$GET1^DIQ(2,$PIECE(GMPLD0,U,2),.09),6,9)
if GMPLPTL4']""
SET GMPLPTL4="UNKN"
+30 SET GMPLPTNM=$$EXTERNAL^DILFD(9000011,.02,"",$PIECE(GMPLD0,U,2))_"|"_GMPLPTL4
+31 SET GMPLNTRT=$SELECT(+$PIECE(GMPLD801,U):"True",1:"False")
SET GMPLNTC=$PIECE(GMPLD801,U,2)
+32 SET @GMPLA@(GMPLDIV,GMPLRPR,GMPLPTNM,GMPLMDT,GMPLDA)=GMPLNARR_U_GMPLSVCA_U_GMPLCLA_U_GMPLNTRT_U_GMPLNTC
End DoDot:1
+33 QUIT
REPORT(GMPLA,GMPLEDT,GMPLLDT,GMPLPCOM) ; Generate report
+1 NEW GMPLDIV,GMPLRTM,DIRUT,DTOUT,DUOUT,GMPLSITE,GMPLCAT,GMPLI,GMPLPG
+2 NEW GMPLSHDR,EQLN
SET $PIECE(EQLN,"-",11)=""
SET GMPLPG=0
SET GMPLPCOM=+$GET(GMPLPCOM)
+3 ; Tell TaskMan to delete Task log entry
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 USE IO
+5 SET GMPLRTM=$$NOW^XLFDT
SET GMPLSITE=$SELECT($$NAME^VASITE]"":$$NAME^VASITE,1:$PIECE($$SITE^VASITE,U,2))
+6 IF '$DATA(@GMPLA)
Begin DoDot:1
+7 DO HEADER("",GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
+8 if $$CONTINUE("",GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
WRITE !
+9 if $$CONTINUE("",GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
WRITE "No Freetext Problems found for selected parameters...",!
+10 IF ($EXTRACT(IOST)="C")
IF ($EXTRACT(IOSL,1,3)'=999)
if '+$$STOP^GMPLUTL1("",1)
SET DIRUT=1
End DoDot:1
QUIT
+11 SET GMPLDIV=0
+12 FOR
SET GMPLDIV=$ORDER(@GMPLA@(GMPLDIV))
if GMPLDIV']""
QUIT
Begin DoDot:1
+13 NEW GMPLRPR
SET GMPLRPR=""
+14 DO HEADER(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
+15 FOR
SET GMPLRPR=$ORDER(@GMPLA@(GMPLDIV,GMPLRPR))
if GMPLRPR']""
QUIT
Begin DoDot:2
+16 NEW GMPLPT
SET GMPLPT=0
+17 FOR
SET GMPLPT=$ORDER(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT))
if GMPLPT']""
QUIT
Begin DoDot:3
+18 NEW GMPLMDT
SET GMPLMDT=0
+19 FOR
SET GMPLMDT=$ORDER(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT))
if +GMPLMDT'>0
QUIT
Begin DoDot:4
+20 NEW GMPLDA
SET GMPLDA=0
+21 FOR
SET GMPLDA=$ORDER(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT,GMPLDA))
if +GMPLDA'>0
QUIT
Begin DoDot:5
+22 NEW GMPLD,GMPLNARR,GMPLPRNM,GMPLPTNM,GMPLSVC,GMPLCLOC,GMPLNTRT,GMPLNTC
+23 SET GMPLD=$GET(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT,GMPLDA))
+24 SET GMPLNARR=$PIECE(GMPLD,U)
SET GMPLSVC=$PIECE(GMPLD,U,2)
SET GMPLCLOC=$PIECE(GMPLD,U,3)
SET GMPLNTRT=$PIECE(GMPLD,U,4)
SET GMPLNTC=$PIECE(GMPLD,U,5)
+25 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+26 WRITE $EXTRACT($$NAME^GMPLUTL1(GMPLRPR,"LAST"),1,10),$$NAME^GMPLUTL1(GMPLRPR,",FI MI")
+27 WRITE ?16,$EXTRACT($$NAME^GMPLUTL1($PIECE(GMPLPT,"|"),"LAST"),1,10),$$NAME^GMPLUTL1($PIECE(GMPLPT,"|"),",FI MI"),?31," (",$PIECE(GMPLPT,"|",2),")"
+28 WRITE ?40,$$DATE^GMPLUTL1(GMPLMDT,"MM/DD/YY"),?50,GMPLSVC,?58,GMPLCLOC,?70,GMPLNTRT,!
+29 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+30 WRITE ?2,GMPLNARR,!
+31 if $DATA(DIRUT)
QUIT
+32 IF GMPLPCOM
IF (GMPLNTC]"")
Begin DoDot:6
+33 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+34 WRITE "Comments: ",!
+35 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+36 WRITE GMPLNTC,!
+37 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+38 WRITE !
End DoDot:6
+39 IF '$TEST
if (+$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0)!$DATA(DIRUT)
QUIT
WRITE !
End DoDot:5
if $DATA(DIRUT)
QUIT
End DoDot:4
if $DATA(DIRUT)
QUIT
End DoDot:3
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+40 if $DATA(DIRUT)
QUIT
+41 IF ($EXTRACT(IOST)="C")
IF ($EXTRACT(IOSL,1,3)'=999)
if '+$$STOP^GMPLUTL1("",1)
SET DIRUT=1
End DoDot:1
if $DATA(DIRUT)
QUIT
+42 QUIT
CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,GMPLPG) ; Evaluate relative page position
+1 NEW GMPLY
SET GMPLY=1
+2 IF $Y'>(IOSL-3)
GOTO CONTX
+3 IF $EXTRACT(IOST)="C"
SET GMPLY=+$$READ^GMPLUTL1("E")
if $DATA(DIRUT)
SET GMPLY=0
+4 IF GMPLY'>0
GOTO CONTX
+5 DO HEADER(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)
CONTX QUIT GMPLY
+1 NEW GMPLLINE,GMPLDTR
SET $PIECE(GMPLLINE,"=",81)=""
SET GMPLDTR=$$DATE^GMPLUTL1(GMPLEDT,"MM/DD/CCYY")_" to "_$$DATE^GMPLUTL1(GMPLLDT,"MM/DD/CCYY")
+2 SET GMPLPG=GMPLPG+1
+3 WRITE @IOF
DO JUSTIFY^GMPLUTL1("Page "_GMPLPG,"R")
WRITE !
+4 WRITE GMPLLINE,!
DO JUSTIFY^GMPLUTL1($$TITLE^GMPLUTL1("PROBLEM LIST FREETEXT FOLLOW-UP REPORT"),"C")
WRITE !
+5 DO JUSTIFY^GMPLUTL1(DIVISION,"C")
+6 WRITE !
+7 WRITE "for Problems Modified: ",GMPLDTR,?55,"Printed: ",$$DATE^GMPLUTL1(GMPLRTM,"MM/DD/CCYY HR:MIN"),!
+8 WRITE !
+9 WRITE "Provider",?16,"Patient",?40,"Modified",?50,"Service",?58,"Clinic",?70,"NTRT",!
+10 WRITE ?2,"Narrative",?70,"Requested",!
+11 WRITE GMPLLINE,!
+12 QUIT
