WVLABLG ;HCIOFO/FT IHS/ANMC/MWR - DISPLAY LAB LOG; ;8/31/98 16:24
;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "WV LAB PRINT LOG" TO PRINT THE "LOG" OF
;; OF PROCEDURES THAT HAVE BEEN ENTERED ("ACCESSIONED").
;
;---> VARIABLES:
;---> DATES: WVBEGDT=BEGINNING DATE, WVENDDT=ENDING DATE
;---> WVA: 1=ALL PROCEDURES, 0=ONLY PROCEDURES WITHOUT RESULTS
;---> WVB: 1=DISPLAY EACH PROCEDURE, 0=TOTALS ONLY
;
D SETVARS^WVUTL5 S WVPOP=0
D TITLE^WVUTL5("PRINT LOG OF PROCEDURES ENTRY")
D DATES G:WVPOP EXIT
D SELECT G:WVPOP EXIT
D FACILITY G:WVPOP EXIT
D RESULT G:WVPOP EXIT
D TOTALS G:WVPOP EXIT
D ORDER G:WVPOP EXIT
D DEVICE G:WVPOP EXIT
D SORT
D COPYGBL
D ^WVLABLG1
;
EXIT ;EP
D KILLALL^WVUTL8
Q
;
DATES ;EP
;---> ASK DATE RANGE. RETURN DATES IN WVBEGDT AND WVENDDT.
;---> LAB PEOPLE GENERALLY LOOK AT THE LOG FOR ONE DAY.
D ASKDATES^WVUTL3(.WVBEGDT,.WVENDDT,.WVPOP,"T-1","",1)
Q
;
SELECT ;EP
;---> SELECT ENTRIES TO SEARCH FOR.
D SELECT^WVSELECT("Accession Area",790.2,"WVAREA","","PAP",.WVPOP)
Q
;
FACILITY ;EP
;---> SELECT FACILITY TO SEARCH FOR.
N B S B=$$INSTTX^WVUTL6(DUZ(2))
W !!?3,"Select the Facility for the log you wish to display."
D DIC^WVFMAN(790.02,"QEMA",.Y," Select FACILITY: ",B)
I Y<0 S WVPOP=1 Q
S WVFAC=+Y
Q
;
RESULT ;EP
;---> DISPLAY ALL PROCEDURES, OR ONLY PROCEDURES WITHOUT RESULTS.
N DIR K DIRUT
W !!?3,"Display ALL Procedures, or only Procedures with NO RESULTS?"
S DIR("A")=" Select ALL or NO RESULTS: ",DIR("B")="ALL"
S DIR(0)="SAM^a:ALL;n:NO RESULTS" D HELP1^WVLABLG2
D ^DIR
I Y=-1!($D(DIRUT)) S WVPOP=1 Q
;---> IF ALL PPROCEDURES, S WVA=1; IF ONLY NO RESULTS, S WVA=0.
S WVA=$S(Y="a":1,1:0)
Q
;
TOTALS ;EP
;---> DISPLAY ALL PROCEDURES, OR ONLY TOTALS.
N DIR
W !!?3,"Display data for EACH Procedure, or just TOTALS?"
S DIR("A")=" Select EACH or TOTALS: ",DIR("B")="EACH"
S DIR(0)="SAM^e:EACH;n:TOTALS" D HELP2^WVLABLG2
D ^DIR
I Y=-1!($D(DIRUT)) S WVPOP=1 Q
;---> IF DISPLAY EACH PROCEDURE, S WVB=1; IF TOTALS ONLY, S WVB=0
S WVB=$S(Y="e":1,1:0)
Q
;
ORDER ;EP
;---> ASK ORDER BY ACCESSION# OR BY PATIENT NAME.
;---> SORT SEQUENCE IN WVC: 1=ACCESSION# (DEFAULT), 2=PATIENT NAME
S WVC=1
;---> QUIT IF DISPLAYING TOTALS ONLY.
Q:'WVB N DIR,DIRUT,Y
W !!?3,"Display Procedures in order of:"
W ?37,"1) ACCESSION# (earliest first)"
W !?37,"2) PATIENT NAME (alphabetically)"
S DIR("A")=" Select 1 or 2: ",DIR("B")=1
S DIR(0)="SAM^1:ACCESSION#;2:PATIENT NAME" D HELP3^WVLABLG2
D ^DIR
I Y=-1!($D(DIRUT)) S WVPOP=1 Q
S WVC=Y
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^WVLABLG"
F WVSV="A","B","C","BEGDT","ENDDT","FAC" D
.I $D(@("WV"_WVSV)) S ZTSAVE("WV"_WVSV)=""
;---> SAVE ATTRIBUTES ARRAY. NOTE: SUBSTITUTE LOCAL ARRAY FOR WVAREA.
I $D(WVAREA) N N S N=0 F S N=$O(WVAREA(N)) Q:N="" D
.S ZTSAVE("WVAREA("""_N_""")")=""
D ZIS^WVUTL2(.WVPOP,1)
Q
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> WVENDDT1=THE LAST SECOND OF END DATE.
;
K ^TMP("WV",$J)
S WVBEGDT1=WVBEGDT-.0001,WVENDDT1=WVENDDT+.9999
S WVDATE=WVBEGDT1
F S WVDATE=$O(^WV(790.1,"ADE",WVDATE)) Q:'WVDATE!(WVDATE>WVENDDT1) D
.S WVIEN=0
.F S WVIEN=$O(^WV(790.1,"ADE",WVDATE,WVIEN)) Q:'WVIEN D
..S Y=^WV(790.1,WVIEN,0),WVDFN=$P(Y,U,2)
..;---> QUIT IF NOT DONE AT THE SELECTED FACILITY.
..Q:$P(Y,U,34)'=WVFAC
..;---> QUIT IF NOT ALL "ACCESSION AREAS" (PROCEDURE TYPES) AND
..;---> THIS DOES NOT MATCH THE SELECTED AREA.
..I '$D(WVAREA("ALL")) Q:$P(Y,U,4)="" Q:'$D(WVAREA($P(Y,U,4)))
..D STORE
Q
;
;
STORE ;EP
;--->WVDATE IS ALREADY SET FROM LL SORT ABOVE. ;---> DATE
S WVCHRT=$$SSN^WVUTL1(WVDFN) ;---> SSN
S WVNAME=$$NAME^WVUTL1(WVDFN) ;---> NAME
S WVACCN=$P(Y,U) ;---> ACCESSION#
S X=$P(Y,U,4),WVPCDN=$$PCDNAM^WVUTL6 ;---> PROC TYPE
S WVDIAG=$$DIAG^WVUTL4($P(Y,U,5)) ;---> RESULT/DIAG
S WVRES=$O(^WV(790.1,WVIEN,1,0)) ;---> RESULT TEXT
;---> QUIT IF DISPLAYING ONLY PROCEDURES WITH NO RESULTS.
Q:'WVA&($P(Y,U,5))
S WVPDATE=$$SLDT2^WVUTL5($P(Y,U,12)) ;---> PROC DATE
S WVRCVDT=$$SLDT2^WVUTL5($P(Y,U,17)) ;---> RCV RES DAT
S X=$P(Y,U,11),WVHLOC=$$HOSPLC^WVUTL6 ;---> HOSP LOC
S X=$P(Y,U,7),WVPROV=$$PROV^WVUTL6 ;---> PROVIDER
S X=$P(Y,U,18),WVUSER=$$PROV^WVUTL6 ;---> ENTERED BY
;
S X=WVCHRT_U_WVNAME_U_WVDATE_U_WVACCN_U_WVPCDN_U_WVRES_U_WVPDATE
S X=X_U_WVHLOC_U_WVPROV_U_WVUSER_U_WVRCVDT_U_WVDIAG_U_WVIEN
I WVC=1 S ^TMP("WV",$J,1,WVDATE,$P(WVACCN,"-"),$P(WVACCN,"-",2))=X Q
I WVC=2 S ^TMP("WV",$J,1,WVDATE,WVNAME,WVACCN)=X Q
Q
;
COPYGBL ;EP
;---> COPY ^TMP("WV",$J,1 TO ^TMP("WV",$J,2 TO MAKE IT FLAT.
N I,M,N,P,Q
S N=0,I=0
F S N=$O(^TMP("WV",$J,1,N)) Q:N="" D
.S M=0
.F S M=$O(^TMP("WV",$J,1,N,M)) Q:M="" D
..S P=0
..F S P=$O(^TMP("WV",$J,1,N,M,P)) Q:P="" D
...S I=I+1,^TMP("WV",$J,2,I)=^TMP("WV",$J,1,N,M,P)
Q
;
DEQUEUE ;EP
;---> TASKMAN QUEUE OF PRINTOUT.
D SETVARS^WVUTL5,SORT,COPYGBL,^WVLABLG1,EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVLABLG 5425 printed Nov 22, 2024@17:56:56 Page 2
WVLABLG ;HCIOFO/FT IHS/ANMC/MWR - DISPLAY LAB LOG; ;8/31/98 16:24
+1 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "WV LAB PRINT LOG" TO PRINT THE "LOG" OF
+4 ;; OF PROCEDURES THAT HAVE BEEN ENTERED ("ACCESSIONED").
+5 ;
+6 ;---> VARIABLES:
+7 ;---> DATES: WVBEGDT=BEGINNING DATE, WVENDDT=ENDING DATE
+8 ;---> WVA: 1=ALL PROCEDURES, 0=ONLY PROCEDURES WITHOUT RESULTS
+9 ;---> WVB: 1=DISPLAY EACH PROCEDURE, 0=TOTALS ONLY
+10 ;
+11 DO SETVARS^WVUTL5
SET WVPOP=0
+12 DO TITLE^WVUTL5("PRINT LOG OF PROCEDURES ENTRY")
+13 DO DATES
if WVPOP
GOTO EXIT
+14 DO SELECT
if WVPOP
GOTO EXIT
+15 DO FACILITY
if WVPOP
GOTO EXIT
+16 DO RESULT
if WVPOP
GOTO EXIT
+17 DO TOTALS
if WVPOP
GOTO EXIT
+18 DO ORDER
if WVPOP
GOTO EXIT
+19 DO DEVICE
if WVPOP
GOTO EXIT
+20 DO SORT
+21 DO COPYGBL
+22 DO ^WVLABLG1
+23 ;
EXIT ;EP
+1 DO KILLALL^WVUTL8
+2 QUIT
+3 ;
DATES ;EP
+1 ;---> ASK DATE RANGE. RETURN DATES IN WVBEGDT AND WVENDDT.
+2 ;---> LAB PEOPLE GENERALLY LOOK AT THE LOG FOR ONE DAY.
+3 DO ASKDATES^WVUTL3(.WVBEGDT,.WVENDDT,.WVPOP,"T-1","",1)
+4 QUIT
+5 ;
SELECT ;EP
+1 ;---> SELECT ENTRIES TO SEARCH FOR.
+2 DO SELECT^WVSELECT("Accession Area",790.2,"WVAREA","","PAP",.WVPOP)
+3 QUIT
+4 ;
FACILITY ;EP
+1 ;---> SELECT FACILITY TO SEARCH FOR.
+2 NEW B
SET B=$$INSTTX^WVUTL6(DUZ(2))
+3 WRITE !!?3,"Select the Facility for the log you wish to display."
+4 DO DIC^WVFMAN(790.02,"QEMA",.Y," Select FACILITY: ",B)
+5 IF Y<0
SET WVPOP=1
QUIT
+6 SET WVFAC=+Y
+7 QUIT
+8 ;
RESULT ;EP
+1 ;---> DISPLAY ALL PROCEDURES, OR ONLY PROCEDURES WITHOUT RESULTS.
+2 NEW DIR
KILL DIRUT
+3 WRITE !!?3,"Display ALL Procedures, or only Procedures with NO RESULTS?"
+4 SET DIR("A")=" Select ALL or NO RESULTS: "
SET DIR("B")="ALL"
+5 SET DIR(0)="SAM^a:ALL;n:NO RESULTS"
DO HELP1^WVLABLG2
+6 DO ^DIR
+7 IF Y=-1!($DATA(DIRUT))
SET WVPOP=1
QUIT
+8 ;---> IF ALL PPROCEDURES, S WVA=1; IF ONLY NO RESULTS, S WVA=0.
+9 SET WVA=$SELECT(Y="a":1,1:0)
+10 QUIT
+11 ;
TOTALS ;EP
+1 ;---> DISPLAY ALL PROCEDURES, OR ONLY TOTALS.
+2 NEW DIR
+3 WRITE !!?3,"Display data for EACH Procedure, or just TOTALS?"
+4 SET DIR("A")=" Select EACH or TOTALS: "
SET DIR("B")="EACH"
+5 SET DIR(0)="SAM^e:EACH;n:TOTALS"
DO HELP2^WVLABLG2
+6 DO ^DIR
+7 IF Y=-1!($DATA(DIRUT))
SET WVPOP=1
QUIT
+8 ;---> IF DISPLAY EACH PROCEDURE, S WVB=1; IF TOTALS ONLY, S WVB=0
+9 SET WVB=$SELECT(Y="e":1,1:0)
+10 QUIT
+11 ;
ORDER ;EP
+1 ;---> ASK ORDER BY ACCESSION# OR BY PATIENT NAME.
+2 ;---> SORT SEQUENCE IN WVC: 1=ACCESSION# (DEFAULT), 2=PATIENT NAME
+3 SET WVC=1
+4 ;---> QUIT IF DISPLAYING TOTALS ONLY.
+5 if 'WVB
QUIT
NEW DIR,DIRUT,Y
+6 WRITE !!?3,"Display Procedures in order of:"
+7 WRITE ?37,"1) ACCESSION# (earliest first)"
+8 WRITE !?37,"2) PATIENT NAME (alphabetically)"
+9 SET DIR("A")=" Select 1 or 2: "
SET DIR("B")=1
+10 SET DIR(0)="SAM^1:ACCESSION#;2:PATIENT NAME"
DO HELP3^WVLABLG2
+11 DO ^DIR
+12 IF Y=-1!($DATA(DIRUT))
SET WVPOP=1
QUIT
+13 SET WVC=Y
+14 QUIT
+15 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^WVLABLG"
+3 FOR WVSV="A","B","C","BEGDT","ENDDT","FAC"
Begin DoDot:1
+4 IF $DATA(@("WV"_WVSV))
SET ZTSAVE("WV"_WVSV)=""
End DoDot:1
+5 ;---> SAVE ATTRIBUTES ARRAY. NOTE: SUBSTITUTE LOCAL ARRAY FOR WVAREA.
+6 IF $DATA(WVAREA)
NEW N
SET N=0
FOR
SET N=$ORDER(WVAREA(N))
if N=""
QUIT
Begin DoDot:1
+7 SET ZTSAVE("WVAREA("""_N_""")")=""
End DoDot:1
+8 DO ZIS^WVUTL2(.WVPOP,1)
+9 QUIT
+10 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
+2 ;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+3 ;---> WVENDDT1=THE LAST SECOND OF END DATE.
+4 ;
+5 KILL ^TMP("WV",$JOB)
+6 SET WVBEGDT1=WVBEGDT-.0001
SET WVENDDT1=WVENDDT+.9999
+7 SET WVDATE=WVBEGDT1
+8 FOR
SET WVDATE=$ORDER(^WV(790.1,"ADE",WVDATE))
if 'WVDATE!(WVDATE>WVENDDT1)
QUIT
Begin DoDot:1
+9 SET WVIEN=0
+10 FOR
SET WVIEN=$ORDER(^WV(790.1,"ADE",WVDATE,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:2
+11 SET Y=^WV(790.1,WVIEN,0)
SET WVDFN=$PIECE(Y,U,2)
+12 ;---> QUIT IF NOT DONE AT THE SELECTED FACILITY.
+13 if $PIECE(Y,U,34)'=WVFAC
QUIT
+14 ;---> QUIT IF NOT ALL "ACCESSION AREAS" (PROCEDURE TYPES) AND
+15 ;---> THIS DOES NOT MATCH THE SELECTED AREA.
+16 IF '$DATA(WVAREA("ALL"))
if $PIECE(Y,U,4)=""
QUIT
if '$DATA(WVAREA($PIECE(Y,U,4)))
QUIT
+17 DO STORE
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;
STORE ;EP
+1 ;--->WVDATE IS ALREADY SET FROM LL SORT ABOVE. ;---> DATE
+2 ;---> SSN
SET WVCHRT=$$SSN^WVUTL1(WVDFN)
+3 ;---> NAME
SET WVNAME=$$NAME^WVUTL1(WVDFN)
+4 ;---> ACCESSION#
SET WVACCN=$PIECE(Y,U)
+5 ;---> PROC TYPE
SET X=$PIECE(Y,U,4)
SET WVPCDN=$$PCDNAM^WVUTL6
+6 ;---> RESULT/DIAG
SET WVDIAG=$$DIAG^WVUTL4($PIECE(Y,U,5))
+7 ;---> RESULT TEXT
SET WVRES=$ORDER(^WV(790.1,WVIEN,1,0))
+8 ;---> QUIT IF DISPLAYING ONLY PROCEDURES WITH NO RESULTS.
+9 if 'WVA&($PIECE(Y,U,5))
QUIT
+10 ;---> PROC DATE
SET WVPDATE=$$SLDT2^WVUTL5($PIECE(Y,U,12))
+11 ;---> RCV RES DAT
SET WVRCVDT=$$SLDT2^WVUTL5($PIECE(Y,U,17))
+12 ;---> HOSP LOC
SET X=$PIECE(Y,U,11)
SET WVHLOC=$$HOSPLC^WVUTL6
+13 ;---> PROVIDER
SET X=$PIECE(Y,U,7)
SET WVPROV=$$PROV^WVUTL6
+14 ;---> ENTERED BY
SET X=$PIECE(Y,U,18)
SET WVUSER=$$PROV^WVUTL6
+15 ;
+16 SET X=WVCHRT_U_WVNAME_U_WVDATE_U_WVACCN_U_WVPCDN_U_WVRES_U_WVPDATE
+17 SET X=X_U_WVHLOC_U_WVPROV_U_WVUSER_U_WVRCVDT_U_WVDIAG_U_WVIEN
+18 IF WVC=1
SET ^TMP("WV",$JOB,1,WVDATE,$PIECE(WVACCN,"-"),$PIECE(WVACCN,"-",2))=X
QUIT
+19 IF WVC=2
SET ^TMP("WV",$JOB,1,WVDATE,WVNAME,WVACCN)=X
QUIT
+20 QUIT
+21 ;
COPYGBL ;EP
+1 ;---> COPY ^TMP("WV",$J,1 TO ^TMP("WV",$J,2 TO MAKE IT FLAT.
+2 NEW I,M,N,P,Q
+3 SET N=0
SET I=0
+4 FOR
SET N=$ORDER(^TMP("WV",$JOB,1,N))
if N=""
QUIT
Begin DoDot:1
+5 SET M=0
+6 FOR
SET M=$ORDER(^TMP("WV",$JOB,1,N,M))
if M=""
QUIT
Begin DoDot:2
+7 SET P=0
+8 FOR
SET P=$ORDER(^TMP("WV",$JOB,1,N,M,P))
if P=""
QUIT
Begin DoDot:3
+9 SET I=I+1
SET ^TMP("WV",$JOB,2,I)=^TMP("WV",$JOB,1,N,M,P)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
DEQUEUE ;EP
+1 ;---> TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS^WVUTL5
DO SORT
DO COPYGBL
DO ^WVLABLG1
DO EXIT
+3 QUIT
