GMPLNTRT ;ISL/JER - Problem List NTRT Mapping Follow-up Report ; 6/19/18 12:53pm
;;2.0;Problem List;**36,52**;Aug 25, 1994;Build 5
;
; ICR #664 - DIVISION^VAUTOMA
; #2055 - $$EXTERNAL^DILFD
; #2056 - $$GET1^DIQ
; #3444 - ^DG(43,1
; #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,GMPLNTST,GMPLDI,VAUTD,ZTRTN,%I,%T,%Y,POP,GMPL1PR,GMPLPR,GMPLPCOM
S GMPLPR=0
W !!,$$CENTER^GMPLUTL1("--- Problem List NTRT Mapping Follow-up Report ---"),!
D SELDIV(.GMPLDI) Q:'$D(GMPLDI)!$D(DIRUT)
W !
S GMPLNTST=$P($$READ^GMPLUTL1("SA^0:All;1:Pending;2:Completed","NTRT Status? ","ALL","Indicate the NTRT Status for the report."),U)
I $D(DIRUT) Q
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(.GMPLPR) Q:'+$G(GMPLPR)!+$G(DIROUT)
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^GMPLNTRT"
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
PROVSEL(GMPLY) ; Select Providers
N DIRUT,GMPLQUIT,GMPLPRSN,GMPLI,GMPLPRMT,GMPLVBCUC,GMPLSCRN,GMPLHLP S (GMPLY,GMPLI,GMPLQUIT)=0
; Identify User Class for VBC Line Count
S GMPLHLP="Please choose a KNOWN Provider (Duplicates not allowed)."
S GMPLSCRN="I '$D(GMPLY(""I"",+Y)),$$CLINUSER^ORQQPL1(+Y)"
W !!,"Select Provider(s):",!
F D Q:+GMPLQUIT
. S GMPLI=GMPLI+1,GMPLPRMT=$J(GMPLI,3)_") "
. S GMPLPRSN=$$READ^GMPLUTL1("PAO^200:AEMQ",GMPLPRMT,"",GMPLHLP,GMPLSCRN)
. I +GMPLPRSN'>0 S GMPLQUIT=1 Q
. S GMPLY=GMPLI,GMPLY(GMPLI)=GMPLPRSN,GMPLY("I",+GMPLPRSN)=GMPLI
W !
Q
SELDIV(GMPLDI) ; Select divisions
;
; Output - SELDIV -1= user ^ at prompt if multidivisional
; 0= institution file pointer missing for
; division entry
; 1= successful division selection
; BADDIV = comma-delimited list of bad divisions (if any)
; GMPLDI( undefined= user <cr> for all divisions or ^ at prompt
; if multidivisional
; defined= user selected one or more divisions if
; multidivisional, or pre-selection of
; division file entry if not multidivisional;
; i.e.: GMPLDI(file #40.8 ien)= Institution
; file pointer for file #40.8 entry
N DIRUT,DTOUT,DUOUT,GMPLI,VAUTD,Y
K SELDIV,GMPLDI,BADDIV
; -- Determine if facility is multidivisional
I $P($G(^DG(43,1,"GL")),U,2) D
. D DIVISION^VAUTOMA
. I Y<0 S SELDIV=-1 Q
. I VAUTD=1 S SELDIV=1 Q
. S GMPLI=0 F S GMPLI=$O(VAUTD(GMPLI)) Q:'GMPLI D ONE(GMPLI,.VAUTD,.GMPLDI)
E S GMPLI=$$PRIM^VASITE D ONE(GMPLI,.VAUTD)
Q:SELDIV=-1
I +SELDIV=0 D Q:'$D(GMPLDI)
. W !!,"Inconsistencies found between the MEDICAL CENTER DIVISION FILE, the INSTITUTION"
. W !,"FILE and/or STATION NUMBER (TIME SENSITIVE) FILE for the:",!!,$S($G(BADDIV)]"":BADDIV_" division"_$S($L(BADDIV,",")>1:"s",1:""),1:"a division you selected"),"."
. W !!,"Please contact the National Support team."
. I '$D(GMPLDI) W ! S:'$$READ^GMPLUTL1("E") DIRUT=1
I $D(GMPLDI) D
. N GMPLK
. S GMPLK=0 F S GMPLK=$O(GMPLDI(GMPLK)) Q:'GMPLK D
. . S GMPLDI("INST",GMPLDI(GMPLK))=GMPLK
. . S GMPLDI("ENTRIES")=$G(GMPLDI("ENTRIES"))_GMPLK_";"
E S GMPLDI("ENTRIES")="ALL DIVISIONS"
Q
;
ONE(GMPLI,VAUTD,GMPLDI) ; Input - GMPLI Medical Center Division file (#40.8) IEN
N GMPLIFP
S GMPLIFP=$P($$SITE^VASITE(,GMPLI),U) I GMPLIFP>0 D
. S GMPLDI(GMPLI)=GMPLIFP,SELDIV=1
E D
. S SELDIV=0,BADDIV=$G(BADDIV)_$S($L($G(BADDIV)):", ",1:"")_$G(VAUTD(GMPLI))
Q
;
ENTRY ; Build & Print Report
N GMPLA
S GMPLA=$NA(^TMP("GMPLNTRT",$J))
U IO
D GATHER(.GMPLDI,GMPLA,GMPLEDT,GMPLLDT,GMPLNTST,.GMPLPR)
D REPORT(GMPLA,GMPLEDT,GMPLLDT)
K @GMPLA
D ^%ZISC
Q
GATHER(GMPLDI,GMPLA,GMPLEDT,GMPLLDT,GMPLNTST,GMPLPR) ; Gather records that satisfy criteria
N GMPLDA,GMPLDT,GMPLNOS,GMPLPOP,GMPLST0,GMPLST1 K @GMPLA
S GMPLNOS=+$$NOS^GMPLX,GMPLDA="",GMPLPOP=0
S GMPLST0=$S(GMPLNTST=0:1,1:GMPLNTST),GMPLST1=$S(GMPLNTST=0:2,1:GMPLNTST)
; Insure inclusive early date/time by subtracting one minute before $ORDER
S GMPLDT=$$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 GMPLDT=$O(^AUPNPROB("DM",GMPLDT)) Q:(+GMPLDT>GMPLLDT)!(+GMPLDT'>0) D Q:+GMPLPOP
. N GMPLSTI F GMPLSTI=GMPLST0:1:GMPLST1 D Q:+GMPLPOP
. . N GMPLDA S GMPLDA=0
. . F S GMPLDA=$O(^AUPNPROB("DM",GMPLDT,GMPLSTI,GMPLDA)) Q:+GMPLDA'>0 D Q:+GMPLPOP
. . . N GMPLD0,GMPLD1,GMPLD800,GMPLDIV,GMPLMDT,GMPLRPR,GMPLPTNM,GMPLPTL4,GMPLNARR
. . . N GMPLSVC,GMPLSVCA,GMPLSVCN,GMPLCL,GMPLCLA,GMPLCLN,GMPLSCTC,GMPLSTAT
. . . S GMPLD0=$G(^AUPNPROB(GMPLDA,0)),GMPLD1=$G(^(1)),GMPLD800=$G(^(800))
. . . 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),GMPLSCTC=$P(GMPLD800,U)
. . . 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=0:"n/a",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 GMPLSTAT=$$EXTERNAL^DILFD(9000011,80005,"",$P(GMPLD800,U,5))
. . . S @GMPLA@(GMPLDIV,GMPLRPR,GMPLPTNM,GMPLMDT,GMPLDA)=GMPLNARR_U_GMPLSVCA_U_GMPLCLA_U_GMPLSCTC_U_GMPLSTAT
Q
REPORT(GMPLA,GMPLEDT,GMPLLDT) ; Generate report
N GMPLDIV,GMPLRTM,DIRUT,DTOUT,DUOUT,GMPLSITE,GMPLPG
N GMPLSHDR,EQLN S $P(EQLN,"-",11)="",GMPLPG=0
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 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,GMPLSCTC,GMPLICD,GMPLSTAT,GMPLNI
. . . . . S GMPLD=$G(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT,GMPLDA))
. . . . . S GMPLNARR=$$WRAP^GMPLX1($P(GMPLD,U),76),GMPLSVC=$P(GMPLD,U,2),GMPLCLOC=$P(GMPLD,U,3),GMPLSCTC=$P(GMPLD,U,4)
. . . . . S GMPLSTAT=$P(GMPLD,U,5),GMPLICD=$S(+GMPLSCTC:$$GETDX^GMPLX(GMPLSCTC,"SCT"),1:"")
. . . . . 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,GMPLSTAT,!
. . . . . F GMPLNI=1:1:$L(GMPLNARR,"|") D Q:$D(DIRUT)
. . . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . . W ?2,$P(GMPLNARR,"|",GMPLNI),!
. . . . . I +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$D(DIRUT) Q
. . . . . W ?2,"SCT: ",GMPLSCTC,?25," ==> ",?40,GMPLICD,!
. . . . . 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 NTRT MAPPING 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 Map",!
W ?2,"Narrative",?70,"Status",!
W GMPLLINE,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLNTRT 10786 printed Oct 16, 2024@18:30:53 Page 2
GMPLNTRT ;ISL/JER - Problem List NTRT Mapping Follow-up Report ; 6/19/18 12:53pm
+1 ;;2.0;Problem List;**36,52**;Aug 25, 1994;Build 5
+2 ;
+3 ; ICR #664 - DIVISION^VAUTOMA
+4 ; #2055 - $$EXTERNAL^DILFD
+5 ; #2056 - $$GET1^DIQ
+6 ; #3444 - ^DG(43,1
+7 ; #3799 - $$FMTE^XLFDT
+8 ; #4558 - $$LEAP^XLFDT3
+9 ; #4631 - $$NOW^XLFDT
+10 ; #10000 - %, %I, %T, %Y Local vars
+11 ; #10063 - ^%ZTLOAD
+12 ; #10086 - ^%ZIS Routine & IO, IOF, ION, IOSL, & IOST Local Vars
+13 ; #10089 - ^%ZISC Routine & IO("Q") Local Var
+14 ; #10104 - $$LOW^XLFSTR, $$UP^XLFSTR
+15 ; #10112 - $$NAME^VASITE, $$SITE^VASITE
+16 ; #10114 - %ZIS Local Var
+17 ;
MAIN ; Main subroutine
+1 NEW DIC,DIRUT,BADDIV,SELDIV,GMPLEDT,GMPLLDT,GMPLNTST,GMPLDI,VAUTD,ZTRTN,%I,%T,%Y,POP,GMPL1PR,GMPLPR,GMPLPCOM
+2 SET GMPLPR=0
+3 WRITE !!,$$CENTER^GMPLUTL1("--- Problem List NTRT Mapping Follow-up Report ---"),!
+4 DO SELDIV(.GMPLDI)
if '$DATA(GMPLDI)!$DATA(DIRUT)
QUIT
+5 WRITE !
+6 SET GMPLNTST=$PIECE($$READ^GMPLUTL1("SA^0:All;1:Pending;2:Completed","NTRT Status? ","ALL","Indicate the NTRT Status for the report."),U)
+7 IF $DATA(DIRUT)
QUIT
+8 WRITE !
+9 SET GMPL1PR=$$READ^GMPLUTL1("YA","Specific Provider(s)? ","NO","Indicate whether you would like to run the report for one or more specific Providers.")
+10 IF $DATA(DIRUT)
QUIT
+11 IF +GMPL1PR
DO PROVSEL(.GMPLPR)
if '+$GET(GMPLPR)!+$GET(DIROUT)
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^GMPLNTRT"
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
PROVSEL(GMPLY) ; Select Providers
+1 NEW DIRUT,GMPLQUIT,GMPLPRSN,GMPLI,GMPLPRMT,GMPLVBCUC,GMPLSCRN,GMPLHLP
SET (GMPLY,GMPLI,GMPLQUIT)=0
+2 ; Identify User Class for VBC Line Count
+3 SET GMPLHLP="Please choose a KNOWN Provider (Duplicates not allowed)."
+4 SET GMPLSCRN="I '$D(GMPLY(""I"",+Y)),$$CLINUSER^ORQQPL1(+Y)"
+5 WRITE !!,"Select Provider(s):",!
+6 FOR
Begin DoDot:1
+7 SET GMPLI=GMPLI+1
SET GMPLPRMT=$JUSTIFY(GMPLI,3)_") "
+8 SET GMPLPRSN=$$READ^GMPLUTL1("PAO^200:AEMQ",GMPLPRMT,"",GMPLHLP,GMPLSCRN)
+9 IF +GMPLPRSN'>0
SET GMPLQUIT=1
QUIT
+10 SET GMPLY=GMPLI
SET GMPLY(GMPLI)=GMPLPRSN
SET GMPLY("I",+GMPLPRSN)=GMPLI
End DoDot:1
if +GMPLQUIT
QUIT
+11 WRITE !
+12 QUIT
SELDIV(GMPLDI) ; Select divisions
+1 ;
+2 ; Output - SELDIV -1= user ^ at prompt if multidivisional
+3 ; 0= institution file pointer missing for
+4 ; division entry
+5 ; 1= successful division selection
+6 ; BADDIV = comma-delimited list of bad divisions (if any)
+7 ; GMPLDI( undefined= user <cr> for all divisions or ^ at prompt
+8 ; if multidivisional
+9 ; defined= user selected one or more divisions if
+10 ; multidivisional, or pre-selection of
+11 ; division file entry if not multidivisional;
+12 ; i.e.: GMPLDI(file #40.8 ien)= Institution
+13 ; file pointer for file #40.8 entry
+14 NEW DIRUT,DTOUT,DUOUT,GMPLI,VAUTD,Y
+15 KILL SELDIV,GMPLDI,BADDIV
+16 ; -- Determine if facility is multidivisional
+17 IF $PIECE($GET(^DG(43,1,"GL")),U,2)
Begin DoDot:1
+18 DO DIVISION^VAUTOMA
+19 IF Y<0
SET SELDIV=-1
QUIT
+20 IF VAUTD=1
SET SELDIV=1
QUIT
+21 SET GMPLI=0
FOR
SET GMPLI=$ORDER(VAUTD(GMPLI))
if 'GMPLI
QUIT
DO ONE(GMPLI,.VAUTD,.GMPLDI)
End DoDot:1
+22 IF '$TEST
SET GMPLI=$$PRIM^VASITE
DO ONE(GMPLI,.VAUTD)
+23 if SELDIV=-1
QUIT
+24 IF +SELDIV=0
Begin DoDot:1
+25 WRITE !!,"Inconsistencies found between the MEDICAL CENTER DIVISION FILE, the INSTITUTION"
+26 WRITE !,"FILE and/or STATION NUMBER (TIME SENSITIVE) FILE for the:",!!,$SELECT($GET(BADDIV)]"":BADDIV_" division"_$SELECT($LENGTH(BADDIV,",")>1:"s",1:""),1:"a division you selected"),"."
+27 WRITE !!,"Please contact the National Support team."
+28 IF '$DATA(GMPLDI)
WRITE !
if '$$READ^GMPLUTL1("E")
SET DIRUT=1
End DoDot:1
if '$DATA(GMPLDI)
QUIT
+29 IF $DATA(GMPLDI)
Begin DoDot:1
+30 NEW GMPLK
+31 SET GMPLK=0
FOR
SET GMPLK=$ORDER(GMPLDI(GMPLK))
if 'GMPLK
QUIT
Begin DoDot:2
+32 SET GMPLDI("INST",GMPLDI(GMPLK))=GMPLK
+33 SET GMPLDI("ENTRIES")=$GET(GMPLDI("ENTRIES"))_GMPLK_";"
End DoDot:2
End DoDot:1
+34 IF '$TEST
SET GMPLDI("ENTRIES")="ALL DIVISIONS"
+35 QUIT
+36 ;
ONE(GMPLI,VAUTD,GMPLDI) ; Input - GMPLI Medical Center Division file (#40.8) IEN
+1 NEW GMPLIFP
+2 SET GMPLIFP=$PIECE($$SITE^VASITE(,GMPLI),U)
IF GMPLIFP>0
Begin DoDot:1
+3 SET GMPLDI(GMPLI)=GMPLIFP
SET SELDIV=1
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET SELDIV=0
SET BADDIV=$GET(BADDIV)_$SELECT($LENGTH($GET(BADDIV)):", ",1:"")_$GET(VAUTD(GMPLI))
End DoDot:1
+6 QUIT
+7 ;
ENTRY ; Build & Print Report
+1 NEW GMPLA
+2 SET GMPLA=$NAME(^TMP("GMPLNTRT",$JOB))
+3 USE IO
+4 DO GATHER(.GMPLDI,GMPLA,GMPLEDT,GMPLLDT,GMPLNTST,.GMPLPR)
+5 DO REPORT(GMPLA,GMPLEDT,GMPLLDT)
+6 KILL @GMPLA
+7 DO ^%ZISC
+8 QUIT
GATHER(GMPLDI,GMPLA,GMPLEDT,GMPLLDT,GMPLNTST,GMPLPR) ; Gather records that satisfy criteria
+1 NEW GMPLDA,GMPLDT,GMPLNOS,GMPLPOP,GMPLST0,GMPLST1
KILL @GMPLA
+2 SET GMPLNOS=+$$NOS^GMPLX
SET GMPLDA=""
SET GMPLPOP=0
+3 SET GMPLST0=$SELECT(GMPLNTST=0:1,1:GMPLNTST)
SET GMPLST1=$SELECT(GMPLNTST=0:2,1:GMPLNTST)
+4 ; Insure inclusive early date/time by subtracting one minute before $ORDER
+5 SET GMPLDT=$$FMADD^XLFDT(GMPLEDT,0,0,-1)
+6 ; Insure inclusive end date/time by appending time of 23:59 if time not indicated
+7 IF $LENGTH(GMPLLDT,".")=1
SET $PIECE(GMPLLDT,".",2)="2359"
+8 FOR
SET GMPLDT=$ORDER(^AUPNPROB("DM",GMPLDT))
if (+GMPLDT>GMPLLDT)!(+GMPLDT'>0)
QUIT
Begin DoDot:1
+9 NEW GMPLSTI
FOR GMPLSTI=GMPLST0:1:GMPLST1
Begin DoDot:2
+10 NEW GMPLDA
SET GMPLDA=0
+11 FOR
SET GMPLDA=$ORDER(^AUPNPROB("DM",GMPLDT,GMPLSTI,GMPLDA))
if +GMPLDA'>0
QUIT
Begin DoDot:3
+12 NEW GMPLD0,GMPLD1,GMPLD800,GMPLDIV,GMPLMDT,GMPLRPR,GMPLPTNM,GMPLPTL4,GMPLNARR
+13 NEW GMPLSVC,GMPLSVCA,GMPLSVCN,GMPLCL,GMPLCLA,GMPLCLN,GMPLSCTC,GMPLSTAT
+14 SET GMPLD0=$GET(^AUPNPROB(GMPLDA,0))
SET GMPLD1=$GET(^(1))
SET GMPLD800=$GET(^(800))
+15 SET GMPLMDT=$PIECE(GMPLD0,U,3)
+16 IF GMPLMDT<GMPLEDT
SET GMPLPOP=1
QUIT
+17 IF GMPLMDT>GMPLLDT
QUIT
+18 SET GMPLRPR=$PIECE(GMPLD1,U,5)
SET GMPLDIV=$PIECE(GMPLD0,U,6)
SET GMPLPTNM=$PIECE(GMPLD0,U,2)
+19 IF +$GET(GMPLPR)
IF '$DATA(GMPLPR("I",+GMPLRPR))
QUIT
+20 IF $SELECT(GMPLDI("ENTRIES")="ALL DIVISIONS":0,$DATA(GMPLDI("INST",+GMPLDIV)):0,1:1)
QUIT
+21 SET GMPLSVC=$PIECE(GMPLD1,U,6)
SET GMPLCL=$PIECE(GMPLD1,U,8)
SET GMPLSCTC=$PIECE(GMPLD800,U)
+22 SET GMPLSVCA=$SELECT(GMPLSVC]"":$EXTRACT($$GET1^DIQ(49,GMPLSVC,1),1,6),1:"n/a")
+23 SET GMPLSVCN=$SELECT(GMPLSVC]"":$EXTRACT($$GET1^DIQ(49,GMPLSVC,.01),1,6),1:"n/a")
+24 SET GMPLSVCA=$SELECT(GMPLSVCA]"":GMPLSVCA,1:GMPLSVCN)
+25 SET GMPLCLA=$SELECT(GMPLCL]"":$EXTRACT($$GET1^DIQ(44,GMPLCL,1),1,6),1:"n/a")
+26 SET GMPLCLN=$SELECT(GMPLCL]"":$EXTRACT($$GET1^DIQ(44,GMPLCL,.01),1,6),1:"n/a")
+27 SET GMPLCLA=$SELECT(GMPLCLA]"":GMPLCLA,1:GMPLCLN)
+28 SET GMPLDIV=$SELECT(GMPLDIV]"":$$EXTERNAL^DILFD(9000011,.06,"",GMPLDIV),1:"DIVISION UNKNOWN")
+29 SET GMPLRPR=$SELECT(GMPLRPR=0:"n/a",GMPLRPR]"":$$EXTERNAL^DILFD(9000011,1.05,"",GMPLRPR),1:"n/a")
+30 SET GMPLNARR=$$EXTERNAL^DILFD(9000011,.05,"",$PIECE(GMPLD0,U,5))
+31 SET GMPLPTL4=$EXTRACT($$GET1^DIQ(2,$PIECE(GMPLD0,U,2),.09),6,9)
if GMPLPTL4']""
SET GMPLPTL4="UNKN"
+32 SET GMPLPTNM=$$EXTERNAL^DILFD(9000011,.02,"",$PIECE(GMPLD0,U,2))_"|"_GMPLPTL4
+33 SET GMPLSTAT=$$EXTERNAL^DILFD(9000011,80005,"",$PIECE(GMPLD800,U,5))
+34 SET @GMPLA@(GMPLDIV,GMPLRPR,GMPLPTNM,GMPLMDT,GMPLDA)=GMPLNARR_U_GMPLSVCA_U_GMPLCLA_U_GMPLSCTC_U_GMPLSTAT
End DoDot:3
if +GMPLPOP
QUIT
End DoDot:2
if +GMPLPOP
QUIT
End DoDot:1
if +GMPLPOP
QUIT
+35 QUIT
REPORT(GMPLA,GMPLEDT,GMPLLDT) ; Generate report
+1 NEW GMPLDIV,GMPLRTM,DIRUT,DTOUT,DUOUT,GMPLSITE,GMPLPG
+2 NEW GMPLSHDR,EQLN
SET $PIECE(EQLN,"-",11)=""
SET GMPLPG=0
+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 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,GMPLSCTC,GMPLICD,GMPLSTAT,GMPLNI
+23 SET GMPLD=$GET(@GMPLA@(GMPLDIV,GMPLRPR,GMPLPT,GMPLMDT,GMPLDA))
+24 SET GMPLNARR=$$WRAP^GMPLX1($PIECE(GMPLD,U),76)
SET GMPLSVC=$PIECE(GMPLD,U,2)
SET GMPLCLOC=$PIECE(GMPLD,U,3)
SET GMPLSCTC=$PIECE(GMPLD,U,4)
+25 SET GMPLSTAT=$PIECE(GMPLD,U,5)
SET GMPLICD=$SELECT(+GMPLSCTC:$$GETDX^GMPLX(GMPLSCTC,"SCT"),1:"")
+26 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+27 WRITE $EXTRACT($$NAME^GMPLUTL1(GMPLRPR,"LAST"),1,10),$$NAME^GMPLUTL1(GMPLRPR,",FI MI")
+28 WRITE ?16,$EXTRACT($$NAME^GMPLUTL1($PIECE(GMPLPT,"|"),"LAST"),1,10),$$NAME^GMPLUTL1($PIECE(GMPLPT,"|"),",FI MI"),?31," (",$PIECE(GMPLPT,"|",2),")"
+29 WRITE ?40,$$DATE^GMPLUTL1(GMPLMDT,"MM/DD/YY"),?50,GMPLSVC,?58,GMPLCLOC,?70,GMPLSTAT,!
+30 FOR GMPLNI=1:1:$LENGTH(GMPLNARR,"|")
Begin DoDot:6
+31 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+32 WRITE ?2,$PIECE(GMPLNARR,"|",GMPLNI),!
End DoDot:6
if $DATA(DIRUT)
QUIT
+33 IF +$$CONTINUE(GMPLDIV,GMPLRTM,GMPLEDT,GMPLLDT,.GMPLPG)'>0!$DATA(DIRUT)
QUIT
+34 WRITE ?2,"SCT: ",GMPLSCTC,?25," ==> ",?40,GMPLICD,!
+35 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
+36 if $DATA(DIRUT)
QUIT
+37 IF ($EXTRACT(IOST)="C")
IF ($EXTRACT(IOSL,1,3)'=999)
if '+$$STOP^GMPLUTL1("",1)
SET DIRUT=1
End DoDot:1
if $DATA(DIRUT)
QUIT
+38 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 NTRT MAPPING 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 Map",!
+10 WRITE ?2,"Narrative",?70,"Status",!
+11 WRITE GMPLLINE,!
+12 QUIT
