WVBRPCD ;HCIOFO/FT,JR IHS/ANMC/MWR - BROWSE PROCEDURES; ;7/30/98 11:07
;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "WV BROWSE PROCEDURES" TO BROWSE AND EDIT
;; PROCEDURES.
;
;---> VARIABLES:
;---> WVA: 1=ALL PATIENTS, 0=ONE PATIENT
;---> WVDFN: DFN OF SELECTED PATIENT
;---> DATES: WVBEGDT=BEGINNING DATE, WVENDDT=ENDING DATE
;---> WVD: 1=BOTH ABNORMAL AND NORMAL, 0=NORMAL ONLY
;---> SORT SEQUENCE IN WVC: 1=DATE, PATIENT, PRIORITY
;---> 2=PATIENT, DATE, PRIORITY
;---> 3=PRIORITY, DATE, PATIENT
;---> USE NODES 1 & 2 IN ^TMP GLOBAL
;
D SETVARS^WVUTL5 S WVPOP=0
D ^WVBRPCD2 G:WVPOP EXIT
D SORT
D COPYGBL
;---> NEXT LINE: PASS TITLE, HEADER (IN ^WVUTL7), AND CODE TO
;---> EXECUTE BY DIR AT BOTTOM OF SCREEN.
D DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
;
EXIT ;EP
D KILLALL^WVUTL8
Q
;
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
K ^TMP("WV",$J)
;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> WVENDDT1=THE LAST SECOND OF END DATE.
S WVBEGDT1=WVBEGDT-.0001,WVENDDT1=WVENDDT+.9999
;
;***********************
;---> WVA=1 ALL PATIENTS
I WVA D Q
.;---> BY DATE GET EITHER ALL OR ABNORMAL ONLY.
.;---> ("INSUFFICIENT TISSUE" IS INCLUDED IN ABNML XREF.)
.S WVXREF=$S(WVD:"D",1:"ABNML")
.S WVDATE=WVBEGDT1
.F S WVDATE=$O(^WV(790.1,WVXREF,WVDATE)) Q:'WVDATE!(WVDATE>WVENDDT1) D
..S WVIEN=0
..F S WVIEN=$O(^WV(790.1,WVXREF,WVDATE,WVIEN)) Q:'WVIEN D
...S Y=^WV(790.1,WVIEN,0),WVDFN=$P(Y,U,2)
...;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
...Q:$P(Y,U,5)=8
...;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS
...;---> NOT ONE OF THE SELECTED PROCEDURES.
...I '$D(WVARR("ALL")) Q:'$D(WVARR($P(Y,U,4)))
...;---> QUIT IF NOT "ALL PROCEDURES" AND THIS ENTRY IS "CLOSED".
...Q:WVB'="a"&($P(Y,U,14)="c")
...;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.
...I 'WVE Q:$P(^WV(790,WVDFN,0),U,10)'=WVCMGR
...;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
...I WVB="d" Q:$P(Y,U,13)>DT!($P(Y,U,13)="")
...;---> QUIT IF LISTING "NEW" AND THIS PROCDURE IS NOT NEW.
...;Q:WVB="n"&($P(Y,U,14)'="n")
...D STORE(WVC,WVIEN,Y)
;
;**********************
;---> WVA=0 ONE PATIENT
S WVIEN=0
F S WVIEN=$O(^WV(790.1,"C",WVDFN,WVIEN)) Q:'WVIEN D
.;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
.S Y=^WV(790.1,WVIEN,0)
.;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
.Q:$P(Y,U,5)=8
.;---> QUIT IF NOT WITHIN DATE RANGE.
.S WVDATE=$P(Y,U,12)
.Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1)
.;---> QUIT IF SELECTING FOR "ABNORMAL" ONLY AND THIS PROCEDURE
.;---> "NORMAL". ("INSUFF TISSUE" AND "UNSAT EXAM" WILL BE "ABNORMAL".)
.Q:'WVD&('$$NORMAL^WVUTL4($P(Y,U,5)))
.;---> QUIT IF "DELINQUENT" OR "OPEN" ONLY AND THIS ENTRY IS "CLOSED".
.Q:WVB'="a"&($P(Y,U,14)="c")
.;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
.I WVB="d" Q:$P(Y,U,13)>DT!($P(Y,U,13)="")
.;Q:WVB="n"&($P(Y,U,14)'="n")
.D STORE(WVC,WVIEN,Y)
Q
;
STORE(WVC,WVIEN,Y) ;EP
;---> CALLED TO STORE PROCEDURES IN ^TMP FOR BROWSING.
;---> WVC=LIST ORDER, WVIEN=IEN OR PROCEDURE, Y=ZERO NODE OF PROCEDURE.
S WVDFN=$P(Y,U,2),WVDATE=$P(Y,U,12) ;---> DFN, DATE
S WVCHRT=$$SSN^WVUTL1(WVDFN)_" " ;---> SSN#
S WVNAME=$$NAME^WVUTL1(WVDFN) ;---> NAME
S WVACC=$P(Y,U) ;---> ACCESSION#
S WVSTAT=$E($$STATUS^WVUTL4) ;---> STATUS
S WVDIAG=$$DIAG^WVUTL4($P(Y,U,5)) ;---> RESULT/DIAG
S X=$P(Y,U,5),WVPRIO=$$PRIOR^WVUTL4 K X ;---> PRIORITY
;
S X=WVCHRT_U_WVNAME_U_WVDATE_U_WVACC_U_WVDIAG_U_WVPRIO_U_WVSTAT_U_WVIEN
I WVC=1 S ^TMP("WV",$J,1,WVDATE,WVNAME,WVPRIO,WVIEN)=X Q
I WVC=2 S ^TMP("WV",$J,1,WVNAME,WVDATE,WVPRIO,WVIEN)=X Q
I WVC=3 S ^TMP("WV",$J,1,WVPRIO,WVDATE,WVNAME,WVIEN)=X
Q
;
COPYGBL ;EP
;---> CALLED TO FLATTEN THE ^TMP ARRAY OF PROCEDURES FOR BROWSING.
;---> 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 Q=0
...F S Q=$O(^TMP("WV",$J,1,N,M,P,Q)) Q:Q="" D
....S I=I+1,^TMP("WV",$J,2,I)=^TMP("WV",$J,1,N,M,P,Q)
Q
;
DEQUEUE ;EP
;---> FOR TASKMAN QUEUE OF PRINTOUT.
D SETVARS^WVUTL5,SORT,COPYGBL
D DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
D EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVBRPCD 4683 printed Apr 09, 2024@21:50:01 Page 2
WVBRPCD ;HCIOFO/FT,JR IHS/ANMC/MWR - BROWSE PROCEDURES; ;7/30/98 11:07
+1 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "WV BROWSE PROCEDURES" TO BROWSE AND EDIT
+4 ;; PROCEDURES.
+5 ;
+6 ;---> VARIABLES:
+7 ;---> WVA: 1=ALL PATIENTS, 0=ONE PATIENT
+8 ;---> WVDFN: DFN OF SELECTED PATIENT
+9 ;---> DATES: WVBEGDT=BEGINNING DATE, WVENDDT=ENDING DATE
+10 ;---> WVD: 1=BOTH ABNORMAL AND NORMAL, 0=NORMAL ONLY
+11 ;---> SORT SEQUENCE IN WVC: 1=DATE, PATIENT, PRIORITY
+12 ;---> 2=PATIENT, DATE, PRIORITY
+13 ;---> 3=PRIORITY, DATE, PATIENT
+14 ;---> USE NODES 1 & 2 IN ^TMP GLOBAL
+15 ;
+16 DO SETVARS^WVUTL5
SET WVPOP=0
+17 DO ^WVBRPCD2
if WVPOP
GOTO EXIT
+18 DO SORT
+19 DO COPYGBL
+20 ;---> NEXT LINE: PASS TITLE, HEADER (IN ^WVUTL7), AND CODE TO
+21 ;---> EXECUTE BY DIR AT BOTTOM OF SCREEN.
+22 DO DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
+23 ;
EXIT ;EP
+1 DO KILLALL^WVUTL8
+2 QUIT
+3 ;
+4 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
+2 KILL ^TMP("WV",$JOB)
+3 ;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+4 ;---> WVENDDT1=THE LAST SECOND OF END DATE.
+5 SET WVBEGDT1=WVBEGDT-.0001
SET WVENDDT1=WVENDDT+.9999
+6 ;
+7 ;***********************
+8 ;---> WVA=1 ALL PATIENTS
+9 IF WVA
Begin DoDot:1
+10 ;---> BY DATE GET EITHER ALL OR ABNORMAL ONLY.
+11 ;---> ("INSUFFICIENT TISSUE" IS INCLUDED IN ABNML XREF.)
+12 SET WVXREF=$SELECT(WVD:"D",1:"ABNML")
+13 SET WVDATE=WVBEGDT1
+14 FOR
SET WVDATE=$ORDER(^WV(790.1,WVXREF,WVDATE))
if 'WVDATE!(WVDATE>WVENDDT1)
QUIT
Begin DoDot:2
+15 SET WVIEN=0
+16 FOR
SET WVIEN=$ORDER(^WV(790.1,WVXREF,WVDATE,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:3
+17 SET Y=^WV(790.1,WVIEN,0)
SET WVDFN=$PIECE(Y,U,2)
+18 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+19 if $PIECE(Y,U,5)=8
QUIT
+20 ;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS
+21 ;---> NOT ONE OF THE SELECTED PROCEDURES.
+22 IF '$DATA(WVARR("ALL"))
if '$DATA(WVARR($PIECE(Y,U,4)))
QUIT
+23 ;---> QUIT IF NOT "ALL PROCEDURES" AND THIS ENTRY IS "CLOSED".
+24 if WVB'="a"&($PIECE(Y,U,14)="c")
QUIT
+25 ;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.
+26 IF 'WVE
if $PIECE(^WV(790,WVDFN,0),U,10)'=WVCMGR
QUIT
+27 ;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
+28 IF WVB="d"
if $PIECE(Y,U,13)>DT!($PIECE(Y,U,13)="")
QUIT
+29 ;---> QUIT IF LISTING "NEW" AND THIS PROCDURE IS NOT NEW.
+30 ;Q:WVB="n"&($P(Y,U,14)'="n")
+31 DO STORE(WVC,WVIEN,Y)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+32 ;
+33 ;**********************
+34 ;---> WVA=0 ONE PATIENT
+35 SET WVIEN=0
+36 FOR
SET WVIEN=$ORDER(^WV(790.1,"C",WVDFN,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:1
+37 ;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
+38 SET Y=^WV(790.1,WVIEN,0)
+39 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+40 if $PIECE(Y,U,5)=8
QUIT
+41 ;---> QUIT IF NOT WITHIN DATE RANGE.
+42 SET WVDATE=$PIECE(Y,U,12)
+43 if WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1)
QUIT
+44 ;---> QUIT IF SELECTING FOR "ABNORMAL" ONLY AND THIS PROCEDURE
+45 ;---> "NORMAL". ("INSUFF TISSUE" AND "UNSAT EXAM" WILL BE "ABNORMAL".)
+46 if 'WVD&('$$NORMAL^WVUTL4($PIECE(Y,U,5)))
QUIT
+47 ;---> QUIT IF "DELINQUENT" OR "OPEN" ONLY AND THIS ENTRY IS "CLOSED".
+48 if WVB'="a"&($PIECE(Y,U,14)="c")
QUIT
+49 ;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
+50 IF WVB="d"
if $PIECE(Y,U,13)>DT!($PIECE(Y,U,13)="")
QUIT
+51 ;Q:WVB="n"&($P(Y,U,14)'="n")
+52 DO STORE(WVC,WVIEN,Y)
End DoDot:1
+53 QUIT
+54 ;
STORE(WVC,WVIEN,Y) ;EP
+1 ;---> CALLED TO STORE PROCEDURES IN ^TMP FOR BROWSING.
+2 ;---> WVC=LIST ORDER, WVIEN=IEN OR PROCEDURE, Y=ZERO NODE OF PROCEDURE.
+3 ;---> DFN, DATE
SET WVDFN=$PIECE(Y,U,2)
SET WVDATE=$PIECE(Y,U,12)
+4 ;---> SSN#
SET WVCHRT=$$SSN^WVUTL1(WVDFN)_" "
+5 ;---> NAME
SET WVNAME=$$NAME^WVUTL1(WVDFN)
+6 ;---> ACCESSION#
SET WVACC=$PIECE(Y,U)
+7 ;---> STATUS
SET WVSTAT=$EXTRACT($$STATUS^WVUTL4)
+8 ;---> RESULT/DIAG
SET WVDIAG=$$DIAG^WVUTL4($PIECE(Y,U,5))
+9 ;---> PRIORITY
SET X=$PIECE(Y,U,5)
SET WVPRIO=$$PRIOR^WVUTL4
KILL X
+10 ;
+11 SET X=WVCHRT_U_WVNAME_U_WVDATE_U_WVACC_U_WVDIAG_U_WVPRIO_U_WVSTAT_U_WVIEN
+12 IF WVC=1
SET ^TMP("WV",$JOB,1,WVDATE,WVNAME,WVPRIO,WVIEN)=X
QUIT
+13 IF WVC=2
SET ^TMP("WV",$JOB,1,WVNAME,WVDATE,WVPRIO,WVIEN)=X
QUIT
+14 IF WVC=3
SET ^TMP("WV",$JOB,1,WVPRIO,WVDATE,WVNAME,WVIEN)=X
+15 QUIT
+16 ;
COPYGBL ;EP
+1 ;---> CALLED TO FLATTEN THE ^TMP ARRAY OF PROCEDURES FOR BROWSING.
+2 ;---> COPY ^TMP("WV",$J,1 TO ^TMP("WV",$J,2 TO MAKE IT FLAT.
+3 NEW I,M,N,P,Q
+4 SET N=0
SET I=0
+5 FOR
SET N=$ORDER(^TMP("WV",$JOB,1,N))
if N=""
QUIT
Begin DoDot:1
+6 SET M=0
+7 FOR
SET M=$ORDER(^TMP("WV",$JOB,1,N,M))
if M=""
QUIT
Begin DoDot:2
+8 SET P=0
+9 FOR
SET P=$ORDER(^TMP("WV",$JOB,1,N,M,P))
if P=""
QUIT
Begin DoDot:3
+10 SET Q=0
+11 FOR
SET Q=$ORDER(^TMP("WV",$JOB,1,N,M,P,Q))
if Q=""
QUIT
Begin DoDot:4
+12 SET I=I+1
SET ^TMP("WV",$JOB,2,I)=^TMP("WV",$JOB,1,N,M,P,Q)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
DEQUEUE ;EP
+1 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS^WVUTL5
DO SORT
DO COPYGBL
+3 DO DISPLAY^WVBRPCD1(WVTITLE,WVHEADER,WVCODE)
+4 DO EXIT
+5 QUIT
