Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMPLNTFT

GMPLNTFT.m

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