- DGMTOREQ ;ALB/TET,CAW,CKN - List Means Test Status ; 5/6/92 ; 07/22/02 11:00am
- ;;5.3;Registration;**33,100,166,182,456**;Aug 13, 1993
- EN ;Entry point to list required/pending means tests
- ST ;select means test status
- I DGMTYPT=1 S DIC("S")="I ""^R^P^""[$P(^(0),U,2)&($P(^(0),U,19)=DGMTYPT)"
- I DGMTYPT=2 S DIC("S")="I ""^I^P^""[$P(^(0),U,2)&($P(^(0),U,19)=DGMTYPT),$$ACT^DGMTDD(Y,DT)",DIC("B")=9 ;Screen Status for Active
- ST1 S DIC(0)="AEQMZ",DIC="^DG(408.32,"
- S DIC("A")="Select "_$S(DGMTYPT=1:"MEANS",1:"COPAY")_" TEST STATUS NAME: "
- D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT)) EXIT G:Y'>0 ST
- S DGCAT(+Y)=$P(Y,U,2)
- ;
- DTB ;select beginning date
- S DIR(0)="DO^::EX",DIR("A")="Enter Beginning Date",DIR("?")="^D HELP^%DTC" D ^DIR K DIR G:$D(DIRUT) EXIT S DGBEG=Y
- I DGBEG>DT W !," Future dates are not allowed.",*7 K DGBEG G DTB
- ;select ending date
- S DIR(0)="D^"_DGBEG_":NOW:EX",DIR("A")="Enter Ending Date",DIR("?")="^D HELP^%DTC" D ^DIR K DIR G:$D(DIRUT) EXIT
- S DGEND=Y
- ;S DGBEG=DGBEG-.1,DGEND=Y_.9
- Q ;select device and print
- S DGVAR="DGCAT#^DGBEG^DGEND^DGMTYPT",DGPGM="DQ^DGMTOREQ"
- D ZIS^DGUTQ G EXIT:POP U IO
- DQ ;gather data and print
- S DGC=$O(DGCAT(0)),DGCRT=$S($E(IOST,1,2)="C-":1,1:0)
- S DGBEGE=$$DATE(DGBEG),DGENDE=$$DATE(DGEND),$P(DGDASH,"=",IOM-1)="",DGPG=0
- S DGC(1)=$S(DGMTYPT=1:"MEANS",1:"COPAY")_" TEST STATUS Report",DGC(2)="STATUS: "_DGCAT(DGC)
- S DGC(3)="From "_DGBEGE_" Through "_DGENDE
- ;flag for new column if Means test type is 1 and report selection is for pending means test data
- S CFLG=0 I (DGMTYPT=1)&(DGC=2) S CFLG=1
- SORT ;sort data into tmp global
- I '$D(^DGMT(408.31,"AS",DGMTYPT,DGC)) S DGM="No patients found with "_$S(DGMTYPT=1:"means",1:"copay")_" test status of "_DGCAT(DGC)_"." D HDR W !!?10,DGM G EXIT
- S DGD=-(DGEND+.9) F S DGD=$O(^DGMT(408.31,"AS",DGMTYPT,DGC,DGD)) Q:'DGD!(DGD>-DGBEG) D
- .S DFN=0 F S DFN=$O(^DGMT(408.31,"AS",DGMTYPT,DGC,DGD,DFN)) Q:'DFN S DGSSN=$$PID(DFN),DGDPT0=$G(^DPT(DFN,0)) I DGDPT0]"" S DGNM=$S($P(DGDPT0,U)]"":$P(DGDPT0,U),1:DFN) D
- ..S DGDA=0 F S DGDA=$O(^DGMT(408.31,"AS",DGMTYPT,DGC,DGD,DFN,DGDA)) Q:'DGDA D
- ...Q:'$G(^DGMT(408.31,DGDA,"PRIM"))
- ...S DGMT0=$G(^DGMT(408.31,DGDA,0)) Q:'DGMT0
- ...S ^TMP($J,"DGMTO",DGNM,DFN,DGDA)=DGSSN_U_$P(DGMT0,U)_U_$$SR^DGMTAUD1(DGMT0)
- ...I CFLG D
- ....S PENDA=$$PA^DGMTUTL(DGDA)
- ....S ^TMP($J,"DGMTO",DGNM,DFN,DGDA)=$G(^TMP($J,"DGMTO",DGNM,DFN,DGDA))_U_PENDA
- I $O(^TMP($J,"DGMTO",0))']"" S DGM="No patients found for requested date range." D HDR W !!?10,DGM G EXIT
- PRINT ;print data from tmp global
- D HDR
- S DGNM=0 F S DGNM=$O(^TMP($J,"DGMTO",DGNM)) Q:DGNM="" D G:$D(DIRUT) EXIT
- .S DFN=0 F S DFN=$O(^TMP($J,"DGMTO",DGNM,DFN)) Q:'DFN D Q:$D(DIRUT)
- ..S DGDA=0 F S DGDA=$O(^TMP($J,"DGMTO",DGNM,DFN,DGDA)) Q:'DGDA D:$Y+10>IOSL PAGE Q:$D(DIRUT) D
- ...S DG0=^TMP($J,"DGMTO",DGNM,DFN,DGDA)
- ...W !,DGNM,?24,$$PID($P(DG0,U)),?38,$P(DG0,U,3),?54,$$DATE($P(DG0,U,2))
- ...I CFLG W ?71,$P(DG0,U,4)
- EXIT ;clean up and quit
- I +$G(DGCRT),$Y'>(IOSL-10) D CR
- K DFN,DG0,DGBEG,DGBEGE,DGC,DGCAT,DGCRT,DGD,DGDA,DGDPT0,DGDASH,DGEND,DGENDE,DGJ,DGM,DGMT0,DGMTYPT,DGNM,DGPG,DGSSN,DIC,DIR,DTOUT,DUOUT,DIRUT,VAERR,X,Y,PENDA,CFLG
- D CLOSE^DGMTUTL,^%ZISC
- K ^TMP($J)
- Q
- HDR ;header
- I DGPG=0,DGCRT W @IOF
- F I=1:1:3 W !?(IOM-$L(DGC(I))/2),DGC(I)
- S DGPG=DGPG+1 W !?66,"Page ",DGPG,!,DGDASH,!
- W !?38,$S(DGMTYPT=1:"Means",1:"Copay")_" Test",?56,"Date of"
- I CFLG W ?67,"Pend. Adj."
- W !,"Patient Name",?24,"Patient ID",?40,"Source",?58,"Test"
- I CFLG W ?69,"Status"
- W !,"------------",?24,"----------",?38,"----------",?56,"-------"
- I CFLG W ?67,"----------"
- Q
- DATE(X) ;function to return date in external format
- ;INPUT - FM internal date format
- ;OUTPUT - external date format
- Q $$FMTE^XLFDT($E(X,1,12),1)
- ;
- PID(X) ;function to return pid
- ;INPUT - DFN
- ;OUTPUT - PID or UNKNOWN
- D PID^VADPT6
- Q $S(VA("PID")]"":VA("PID"),1:"UNKNOWN")
- ;
- CR ;read for display
- S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) DIRUT=1
- Q
- PAGE ;new page
- I DGCRT D CR Q:$D(DIRUT)
- W @IOF
- D HDR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTOREQ 4081 printed Feb 19, 2025@00:11:09 Page 2
- DGMTOREQ ;ALB/TET,CAW,CKN - List Means Test Status ; 5/6/92 ; 07/22/02 11:00am
- +1 ;;5.3;Registration;**33,100,166,182,456**;Aug 13, 1993
- EN ;Entry point to list required/pending means tests
- ST ;select means test status
- +1 IF DGMTYPT=1
- SET DIC("S")="I ""^R^P^""[$P(^(0),U,2)&($P(^(0),U,19)=DGMTYPT)"
- +2 ;Screen Status for Active
- IF DGMTYPT=2
- SET DIC("S")="I ""^I^P^""[$P(^(0),U,2)&($P(^(0),U,19)=DGMTYPT),$$ACT^DGMTDD(Y,DT)"
- SET DIC("B")=9
- ST1 SET DIC(0)="AEQMZ"
- SET DIC="^DG(408.32,"
- +1 SET DIC("A")="Select "_$SELECT(DGMTYPT=1:"MEANS",1:"COPAY")_" TEST STATUS NAME: "
- +2 DO ^DIC
- KILL DIC
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT
- if Y'>0
- GOTO ST
- +3 SET DGCAT(+Y)=$PIECE(Y,U,2)
- +4 ;
- DTB ;select beginning date
- +1 SET DIR(0)="DO^::EX"
- SET DIR("A")="Enter Beginning Date"
- SET DIR("?")="^D HELP^%DTC"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO EXIT
- SET DGBEG=Y
- +2 IF DGBEG>DT
- WRITE !," Future dates are not allowed.",*7
- KILL DGBEG
- GOTO DTB
- +3 ;select ending date
- +4 SET DIR(0)="D^"_DGBEG_":NOW:EX"
- SET DIR("A")="Enter Ending Date"
- SET DIR("?")="^D HELP^%DTC"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO EXIT
- +5 SET DGEND=Y
- +6 ;S DGBEG=DGBEG-.1,DGEND=Y_.9
- Q ;select device and print
- +1 SET DGVAR="DGCAT#^DGBEG^DGEND^DGMTYPT"
- SET DGPGM="DQ^DGMTOREQ"
- +2 DO ZIS^DGUTQ
- if POP
- GOTO EXIT
- USE IO
- DQ ;gather data and print
- +1 SET DGC=$ORDER(DGCAT(0))
- SET DGCRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
- +2 SET DGBEGE=$$DATE(DGBEG)
- SET DGENDE=$$DATE(DGEND)
- SET $PIECE(DGDASH,"=",IOM-1)=""
- SET DGPG=0
- +3 SET DGC(1)=$SELECT(DGMTYPT=1:"MEANS",1:"COPAY")_" TEST STATUS Report"
- SET DGC(2)="STATUS: "_DGCAT(DGC)
- +4 SET DGC(3)="From "_DGBEGE_" Through "_DGENDE
- +5 ;flag for new column if Means test type is 1 and report selection is for pending means test data
- +6 SET CFLG=0
- IF (DGMTYPT=1)&(DGC=2)
- SET CFLG=1
- SORT ;sort data into tmp global
- +1 IF '$DATA(^DGMT(408.31,"AS",DGMTYPT,DGC))
- SET DGM="No patients found with "_$SELECT(DGMTYPT=1:"means",1:"copay")_" test status of "_DGCAT(DGC)_"."
- DO HDR
- WRITE !!?10,DGM
- GOTO EXIT
- +2 SET DGD=-(DGEND+.9)
- FOR
- SET DGD=$ORDER(^DGMT(408.31,"AS",DGMTYPT,DGC,DGD))
- if 'DGD!(DGD>-DGBEG)
- QUIT
- Begin DoDot:1
- +3 SET DFN=0
- FOR
- SET DFN=$ORDER(^DGMT(408.31,"AS",DGMTYPT,DGC,DGD,DFN))
- if 'DFN
- QUIT
- SET DGSSN=$$PID(DFN)
- SET DGDPT0=$GET(^DPT(DFN,0))
- IF DGDPT0]""
- SET DGNM=$SELECT($PIECE(DGDPT0,U)]"":$PIECE(DGDPT0,U),1:DFN)
- Begin DoDot:2
- +4 SET DGDA=0
- FOR
- SET DGDA=$ORDER(^DGMT(408.31,"AS",DGMTYPT,DGC,DGD,DFN,DGDA))
- if 'DGDA
- QUIT
- Begin DoDot:3
- +5 if '$GET(^DGMT(408.31,DGDA,"PRIM"))
- QUIT
- +6 SET DGMT0=$GET(^DGMT(408.31,DGDA,0))
- if 'DGMT0
- QUIT
- +7 SET ^TMP($JOB,"DGMTO",DGNM,DFN,DGDA)=DGSSN_U_$PIECE(DGMT0,U)_U_$$SR^DGMTAUD1(DGMT0)
- +8 IF CFLG
- Begin DoDot:4
- +9 SET PENDA=$$PA^DGMTUTL(DGDA)
- +10 SET ^TMP($JOB,"DGMTO",DGNM,DFN,DGDA)=$GET(^TMP($JOB,"DGMTO",DGNM,DFN,DGDA))_U_PENDA
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 IF $ORDER(^TMP($JOB,"DGMTO",0))']""
- SET DGM="No patients found for requested date range."
- DO HDR
- WRITE !!?10,DGM
- GOTO EXIT
- PRINT ;print data from tmp global
- +1 DO HDR
- +2 SET DGNM=0
- FOR
- SET DGNM=$ORDER(^TMP($JOB,"DGMTO",DGNM))
- if DGNM=""
- QUIT
- Begin DoDot:1
- +3 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP($JOB,"DGMTO",DGNM,DFN))
- if 'DFN
- QUIT
- Begin DoDot:2
- +4 SET DGDA=0
- FOR
- SET DGDA=$ORDER(^TMP($JOB,"DGMTO",DGNM,DFN,DGDA))
- if 'DGDA
- QUIT
- if $Y+10>IOSL
- DO PAGE
- if $DATA(DIRUT)
- QUIT
- Begin DoDot:3
- +5 SET DG0=^TMP($JOB,"DGMTO",DGNM,DFN,DGDA)
- +6 WRITE !,DGNM,?24,$$PID($PIECE(DG0,U)),?38,$PIECE(DG0,U,3),?54,$$DATE($PIECE(DG0,U,2))
- +7 IF CFLG
- WRITE ?71,$PIECE(DG0,U,4)
- End DoDot:3
- End DoDot:2
- if $DATA(DIRUT)
- QUIT
- End DoDot:1
- if $DATA(DIRUT)
- GOTO EXIT
- EXIT ;clean up and quit
- +1 IF +$GET(DGCRT)
- IF $Y'>(IOSL-10)
- DO CR
- +2 KILL DFN,DG0,DGBEG,DGBEGE,DGC,DGCAT,DGCRT,DGD,DGDA,DGDPT0,DGDASH,DGEND,DGENDE,DGJ,DGM,DGMT0,DGMTYPT,DGNM,DGPG,DGSSN,DIC,DIR,DTOUT,DUOUT,DIRUT,VAERR,X,Y,PENDA,CFLG
- +3 DO CLOSE^DGMTUTL
- DO ^%ZISC
- +4 KILL ^TMP($JOB)
- +5 QUIT
- HDR ;header
- +1 IF DGPG=0
- IF DGCRT
- WRITE @IOF
- +2 FOR I=1:1:3
- WRITE !?(IOM-$LENGTH(DGC(I))/2),DGC(I)
- +3 SET DGPG=DGPG+1
- WRITE !?66,"Page ",DGPG,!,DGDASH,!
- +4 WRITE !?38,$SELECT(DGMTYPT=1:"Means",1:"Copay")_" Test",?56,"Date of"
- +5 IF CFLG
- WRITE ?67,"Pend. Adj."
- +6 WRITE !,"Patient Name",?24,"Patient ID",?40,"Source",?58,"Test"
- +7 IF CFLG
- WRITE ?69,"Status"
- +8 WRITE !,"------------",?24,"----------",?38,"----------",?56,"-------"
- +9 IF CFLG
- WRITE ?67,"----------"
- +10 QUIT
- DATE(X) ;function to return date in external format
- +1 ;INPUT - FM internal date format
- +2 ;OUTPUT - external date format
- +3 QUIT $$FMTE^XLFDT($EXTRACT(X,1,12),1)
- +4 ;
- PID(X) ;function to return pid
- +1 ;INPUT - DFN
- +2 ;OUTPUT - PID or UNKNOWN
- +3 DO PID^VADPT6
- +4 QUIT $SELECT(VA("PID")]"":VA("PID"),1:"UNKNOWN")
- +5 ;
- CR ;read for display
- +1 SET DIR(0)="E"
- WRITE !
- DO ^DIR
- KILL DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- SET DIRUT=1
- +2 QUIT
- PAGE ;new page
- +1 IF DGCRT
- DO CR
- if $DATA(DIRUT)
- QUIT
- +2 WRITE @IOF
- +3 DO HDR
- +4 QUIT
