- WVDIAG ;HCIOFO/FT,JR IHS/ANMC/MWR - PRINTOUT OF WV DIAGNOSIS FILE; ;8/10/98 14:56
- ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
- ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- ;; CALLED BY OPTION: "WV PRINT RES/DIAG FILE" TO PRINT THE
- ;; RESULTS/DIAGNOSIS TABLE FILE.
- ;
- D SETUP
- D TITLE^WVUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
- D DEVICE I WVPOP D EXIT Q
- D SORT
- D DISPLAY
- ;
- EXIT ;EP
- D KILLALL^WVUTL8
- Q
- ;
- SETUP ;EP
- D SETVARS^WVUTL5 S WVPOP=0
- S WVLINE=$$REPEAT^XLFSTR("-",80)
- Q
- ;
- DEVICE ;EP
- ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
- S ZTRTN="DEQUEUE^WVDIAG"
- F WVSV="WVLINE","WVTITLE" D
- .I $D(WVSV) S ZTSAVE(WVSV)=""
- D ZIS^WVUTL2(.WVPOP,1)
- Q
- ;
- SORT ;EP
- ;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("WV",$J,1
- N N,X,Y K ^TMP("WV",$J)
- S N=0
- F S N=$O(^WV(790.31,"B",N)) Q:N="" D
- .S M=$O(^WV(790.31,"B",N,0))
- .S Y=^WV(790.31,M,0),WVDIAG=N
- .F I=3:1:19 I $P(Y,U,I) D
- ..S WVPN=$E($P(^WV(790.2,$P(Y,U,I),0),U),1,30)
- ..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- ..S WVPRIO=$P(Y,U,2)
- ..S X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
- ..S ^TMP("WV",$J,1,WVDIAG,WVPN,1)=X
- .I $P(Y,U,20) D
- ..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- ..S WVPRIO=$P(Y,U,2),WVPN="ALL PROCEDURES"
- ..S X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
- ..S ^TMP("WV",$J,1,WVDIAG,WVPN,1)=X
- ;
- ;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("WV",$J,2
- S N=0
- F S N=$O(^WV(790.31,"P",N)) Q:N="" D
- .S M=0
- .F S M=$O(^WV(790.31,"P",N,M)) Q:M="" D
- ..S Y=^WV(790.31,M,0)
- ..S WVPN=$P(^WV(790.2,N,0),U),WVDIAG=$P(Y,U)
- ..S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- ..S WVPRIO=$P(Y,U,2)
- ..S X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
- ..S ^TMP("WV",$J,2,WVPN,WVPRIO,WVDIAG)=X
- ;
- ;---> ASSOCIATED WITH ALL PROCEDURES
- S N=0
- F S N=$O(^WV(790.31,N)) Q:'N D
- .S Y=^WV(790.31,N,0)
- .Q:'$P(Y,U,20)
- .S WVDIAG=$P(Y,U),WVPRIO=$P(Y,U,2)
- .S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- .S M=0
- .F S M=$O(^WV(790.2,M)) Q:'M D
- ..S WVPN=$P(^WV(790.2,M,0),U)
- ..Q:$P(^WV(790.2,M,0),U,12)
- ..S X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
- ..S ^TMP("WV",$J,2,WVPN,WVPRIO,WVDIAG)=X
- ;
- ;---> SORT BY PRIORITY. STORED IN ^TMP("WV",$J,3
- S N=0
- F S N=$O(^WV(790.31,"B",N)) Q:N="" D
- .S M=$O(^WV(790.31,"B",N,0))
- .S Y=^WV(790.31,M,0),WVDIAG=N,WVPRIO=$P(Y,U,2)
- .S X=$P(Y,U,21),WVNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- .S X=WVDIAG_U_WVPRIO_U_WVNORM
- .S ^TMP("WV",$J,3,WVPRIO,WVDIAG,1)=X
- ;
- ;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
- F WVS=1,2,3 S WVSS=WVS_WVS D COPYGBL
- Q
- ;
- DISPLAY ;EP
- U IO
- S WVTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
- D CENTERT^WVUTL5(.WVTITLE1)
- S WVCRT=$S($E(IOST)="C":1,1:0),(WVPAGE,WVPOP)=0
- F WVI=22,33,11 D @("DISPLY"_WVI) Q:WVPOP
- D ^%ZISC
- Q
- ;
- DISPLY11 ;EP
- ;---> LIST BY RESULT/DIAGNOSIS
- ;Q
- S WVTITLE2=" * BY DIAGNOSIS *" D CENTERT^WVUTL5(.WVTITLE2)
- S WVSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
- S WVSUB=WVSUB_"?50,""ASSOCIATED PROCEDURES"""
- N Z S (WVPOP,N,Z)=0
- W:WVCRT @IOF D HEADER
- F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
- .I $Y+8>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
- .S Y=^TMP("WV",$J,WVI,N) W !
- .I $P(Y,U)'=Z W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?42,$P(Y,U,3)
- .W ?50,$P(Y,U,4)
- .S Z=$P(Y,U)
- I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
- Q
- ;
- DISPLY22 ;EP
- ;---> LIST BY RESULT/DIAGNOSIS
- S WVTITLE2=" * BY PROCEDURE *" D CENTERT^WVUTL5(.WVTITLE2)
- S WVSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
- S WVSUB=WVSUB_",?62,""PRIORITY"",?72,""NORMAL"""
- N Z S (WVPOP,N,Z)=0
- W:WVCRT @IOF D HEADER
- F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
- .I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
- .S Y=^TMP("WV",$J,WVI,N) W !
- .I $P(Y,U)'=Z W !?3,$P(Y,U)
- .W ?35,$P(Y,U,2),?68,$J($P(Y,U,3),2),?72,$P(Y,U,4)
- .S Z=$P(Y,U)
- I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
- Q
- ;
- DISPLY33 ;EP
- ;---> LIST BY RESULT/DIAGNOSIS
- S WVTITLE2=" * BY PRIORITY *" D CENTERT^WVUTL5(.WVTITLE2)
- S WVSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
- N Z S (WVPOP,N,Z)=0
- W:WVCRT @IOF D HEADER
- F S N=$O(^TMP("WV",$J,WVI,N)) Q:'N!(WVPOP) D
- .I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER
- .S Y=^TMP("WV",$J,WVI,N)
- .W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?44,$P(Y,U,3)
- .S Z=$P(Y,U)
- I WVCRT&('WVPOP) W !! D DIRZ^WVUTL3
- Q
- ;
- ;
- W:WVPAGE @IOF S WVPAGE=WVPAGE+1,Z=0
- W WVTITLE1,?70,"PAGE ",WVPAGE,!,WVTITLE2
- W !,$$RUNDT^WVUTL1A("C")
- W !,WVLINE X WVSUB W !,WVLINE
- Q
- ;
- COPYGBL ;EP
- ;---> COPY ^TMP("WV",$J,WVS TO ^TMP("WV",$J,WVSS TO MAKE IT FLAT.
- N I,M,N,P,Q
- S N=0,I=0
- F S N=$O(^TMP("WV",$J,WVS,N)) Q:N="" D
- .S M=0
- .F S M=$O(^TMP("WV",$J,WVS,N,M)) Q:M="" D
- ..S P=0
- ..F S P=$O(^TMP("WV",$J,WVS,N,M,P)) Q:P="" D
- ...S I=I+1,^TMP("WV",$J,WVSS,I)=^TMP("WV",$J,WVS,N,M,P)
- Q
- ;
- DEQUEUE ;EP
- ;---> CALLED BY TASKMAN
- D SETVARS^WVUTL5,SORT,DISPLAY,EXIT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVDIAG 4976 printed Feb 19, 2025@00:13:20 Page 2
- WVDIAG ;HCIOFO/FT,JR IHS/ANMC/MWR - PRINTOUT OF WV DIAGNOSIS FILE; ;8/10/98 14:56
- +1 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
- +2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- +3 ;; CALLED BY OPTION: "WV PRINT RES/DIAG FILE" TO PRINT THE
- +4 ;; RESULTS/DIAGNOSIS TABLE FILE.
- +5 ;
- +6 DO SETUP
- +7 DO TITLE^WVUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
- +8 DO DEVICE
- IF WVPOP
- DO EXIT
- QUIT
- +9 DO SORT
- +10 DO DISPLAY
- +11 ;
- EXIT ;EP
- +1 DO KILLALL^WVUTL8
- +2 QUIT
- +3 ;
- SETUP ;EP
- +1 DO SETVARS^WVUTL5
- SET WVPOP=0
- +2 SET WVLINE=$$REPEAT^XLFSTR("-",80)
- +3 QUIT
- +4 ;
- DEVICE ;EP
- +1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
- +2 SET ZTRTN="DEQUEUE^WVDIAG"
- +3 FOR WVSV="WVLINE","WVTITLE"
- Begin DoDot:1
- +4 IF $DATA(WVSV)
- SET ZTSAVE(WVSV)=""
- End DoDot:1
- +5 DO ZIS^WVUTL2(.WVPOP,1)
- +6 QUIT
- +7 ;
- SORT ;EP
- +1 ;---> SORT BY RESULT/DIAGNOSIS. STORED IN ^TMP("WV",$J,1
- +2 NEW N,X,Y
- KILL ^TMP("WV",$JOB)
- +3 SET N=0
- +4 FOR
- SET N=$ORDER(^WV(790.31,"B",N))
- if N=""
- QUIT
- Begin DoDot:1
- +5 SET M=$ORDER(^WV(790.31,"B",N,0))
- +6 SET Y=^WV(790.31,M,0)
- SET WVDIAG=N
- +7 FOR I=3:1:19
- IF $PIECE(Y,U,I)
- Begin DoDot:2
- +8 SET WVPN=$EXTRACT($PIECE(^WV(790.2,$PIECE(Y,U,I),0),U),1,30)
- +9 SET X=$PIECE(Y,U,21)
- SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- +10 SET WVPRIO=$PIECE(Y,U,2)
- +11 SET X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
- +12 SET ^TMP("WV",$JOB,1,WVDIAG,WVPN,1)=X
- End DoDot:2
- +13 IF $PIECE(Y,U,20)
- Begin DoDot:2
- +14 SET X=$PIECE(Y,U,21)
- SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- +15 SET WVPRIO=$PIECE(Y,U,2)
- SET WVPN="ALL PROCEDURES"
- +16 SET X=WVDIAG_U_WVPRIO_U_WVNORM_U_WVPN
- +17 SET ^TMP("WV",$JOB,1,WVDIAG,WVPN,1)=X
- End DoDot:2
- End DoDot:1
- +18 ;
- +19 ;---> SORT BY PROCEDURE TYPE. STORED IN ^TMP("WV",$J,2
- +20 SET N=0
- +21 FOR
- SET N=$ORDER(^WV(790.31,"P",N))
- if N=""
- QUIT
- Begin DoDot:1
- +22 SET M=0
- +23 FOR
- SET M=$ORDER(^WV(790.31,"P",N,M))
- if M=""
- QUIT
- Begin DoDot:2
- +24 SET Y=^WV(790.31,M,0)
- +25 SET WVPN=$PIECE(^WV(790.2,N,0),U)
- SET WVDIAG=$PIECE(Y,U)
- +26 SET X=$PIECE(Y,U,21)
- SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- +27 SET WVPRIO=$PIECE(Y,U,2)
- +28 SET X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
- +29 SET ^TMP("WV",$JOB,2,WVPN,WVPRIO,WVDIAG)=X
- End DoDot:2
- End DoDot:1
- +30 ;
- +31 ;---> ASSOCIATED WITH ALL PROCEDURES
- +32 SET N=0
- +33 FOR
- SET N=$ORDER(^WV(790.31,N))
- if 'N
- QUIT
- Begin DoDot:1
- +34 SET Y=^WV(790.31,N,0)
- +35 if '$PIECE(Y,U,20)
- QUIT
- +36 SET WVDIAG=$PIECE(Y,U)
- SET WVPRIO=$PIECE(Y,U,2)
- +37 SET X=$PIECE(Y,U,21)
- SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- +38 SET M=0
- +39 FOR
- SET M=$ORDER(^WV(790.2,M))
- if 'M
- QUIT
- Begin DoDot:2
- +40 SET WVPN=$PIECE(^WV(790.2,M,0),U)
- +41 if $PIECE(^WV(790.2,M,0),U,12)
- QUIT
- +42 SET X=WVPN_U_WVDIAG_U_WVPRIO_U_WVNORM
- +43 SET ^TMP("WV",$JOB,2,WVPN,WVPRIO,WVDIAG)=X
- End DoDot:2
- End DoDot:1
- +44 ;
- +45 ;---> SORT BY PRIORITY. STORED IN ^TMP("WV",$J,3
- +46 SET N=0
- +47 FOR
- SET N=$ORDER(^WV(790.31,"B",N))
- if N=""
- QUIT
- Begin DoDot:1
- +48 SET M=$ORDER(^WV(790.31,"B",N,0))
- +49 SET Y=^WV(790.31,M,0)
- SET WVDIAG=N
- SET WVPRIO=$PIECE(Y,U,2)
- +50 SET X=$PIECE(Y,U,21)
- SET WVNORM=$SELECT(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
- +51 SET X=WVDIAG_U_WVPRIO_U_WVNORM
- +52 SET ^TMP("WV",$JOB,3,WVPRIO,WVDIAG,1)=X
- End DoDot:1
- +53 ;
- +54 ;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
- +55 FOR WVS=1,2,3
- SET WVSS=WVS_WVS
- DO COPYGBL
- +56 QUIT
- +57 ;
- DISPLAY ;EP
- +1 USE IO
- +2 SET WVTITLE1="* WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE *"
- +3 DO CENTERT^WVUTL5(.WVTITLE1)
- +4 SET WVCRT=$SELECT($EXTRACT(IOST)="C":1,1:0)
- SET (WVPAGE,WVPOP)=0
- +5 FOR WVI=22,33,11
- DO @("DISPLY"_WVI)
- if WVPOP
- QUIT
- +6 DO ^%ZISC
- +7 QUIT
- +8 ;
- DISPLY11 ;EP
- +1 ;---> LIST BY RESULT/DIAGNOSIS
- +2 ;Q
- +3 SET WVTITLE2=" * BY DIAGNOSIS *"
- DO CENTERT^WVUTL5(.WVTITLE2)
- +4 SET WVSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
- +5 SET WVSUB=WVSUB_"?50,""ASSOCIATED PROCEDURES"""
- +6 NEW Z
- SET (WVPOP,N,Z)=0
- +7 if WVCRT
- WRITE @IOF
- DO HEADER
- +8 FOR
- SET N=$ORDER(^TMP("WV",$JOB,WVI,N))
- if 'N!(WVPOP)
- QUIT
- Begin DoDot:1
- +9 IF $Y+8>IOSL
- if WVCRT
- DO DIRZ^WVUTL3
- if WVPOP
- QUIT
- DO HEADER
- +10 SET Y=^TMP("WV",$JOB,WVI,N)
- WRITE !
- +11 IF $PIECE(Y,U)'=Z
- WRITE !?3,$PIECE(Y,U),?37,$JUSTIFY($PIECE(Y,U,2),2),?42,$PIECE(Y,U,3)
- +12 WRITE ?50,$PIECE(Y,U,4)
- +13 SET Z=$PIECE(Y,U)
- End DoDot:1
- +14 IF WVCRT&('WVPOP)
- WRITE !!
- DO DIRZ^WVUTL3
- +15 QUIT
- +16 ;
- DISPLY22 ;EP
- +1 ;---> LIST BY RESULT/DIAGNOSIS
- +2 SET WVTITLE2=" * BY PROCEDURE *"
- DO CENTERT^WVUTL5(.WVTITLE2)
- +3 SET WVSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
- +4 SET WVSUB=WVSUB_",?62,""PRIORITY"",?72,""NORMAL"""
- +5 NEW Z
- SET (WVPOP,N,Z)=0
- +6 if WVCRT
- WRITE @IOF
- DO HEADER
- +7 FOR
- SET N=$ORDER(^TMP("WV",$JOB,WVI,N))
- if 'N!(WVPOP)
- QUIT
- Begin DoDot:1
- +8 IF $Y+6>IOSL
- if WVCRT
- DO DIRZ^WVUTL3
- if WVPOP
- QUIT
- DO HEADER
- +9 SET Y=^TMP("WV",$JOB,WVI,N)
- WRITE !
- +10 IF $PIECE(Y,U)'=Z
- WRITE !?3,$PIECE(Y,U)
- +11 WRITE ?35,$PIECE(Y,U,2),?68,$JUSTIFY($PIECE(Y,U,3),2),?72,$PIECE(Y,U,4)
- +12 SET Z=$PIECE(Y,U)
- End DoDot:1
- +13 IF WVCRT&('WVPOP)
- WRITE !!
- DO DIRZ^WVUTL3
- +14 QUIT
- +15 ;
- DISPLY33 ;EP
- +1 ;---> LIST BY RESULT/DIAGNOSIS
- +2 SET WVTITLE2=" * BY PRIORITY *"
- DO CENTERT^WVUTL5(.WVTITLE2)
- +3 SET WVSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
- +4 NEW Z
- SET (WVPOP,N,Z)=0
- +5 if WVCRT
- WRITE @IOF
- DO HEADER
- +6 FOR
- SET N=$ORDER(^TMP("WV",$JOB,WVI,N))
- if 'N!(WVPOP)
- QUIT
- Begin DoDot:1
- +7 IF $Y+6>IOSL
- if WVCRT
- DO DIRZ^WVUTL3
- if WVPOP
- QUIT
- DO HEADER
- +8 SET Y=^TMP("WV",$JOB,WVI,N)
- +9 WRITE !?3,$PIECE(Y,U),?37,$JUSTIFY($PIECE(Y,U,2),2),?44,$PIECE(Y,U,3)
- +10 SET Z=$PIECE(Y,U)
- End DoDot:1
- +11 IF WVCRT&('WVPOP)
- WRITE !!
- DO DIRZ^WVUTL3
- +12 QUIT
- +13 ;
- +14 ;
- +1 if WVPAGE
- WRITE @IOF
- SET WVPAGE=WVPAGE+1
- SET Z=0
- +2 WRITE WVTITLE1,?70,"PAGE ",WVPAGE,!,WVTITLE2
- +3 WRITE !,$$RUNDT^WVUTL1A("C")
- +4 WRITE !,WVLINE
- XECUTE WVSUB
- WRITE !,WVLINE
- +5 QUIT
- +6 ;
- COPYGBL ;EP
- +1 ;---> COPY ^TMP("WV",$J,WVS TO ^TMP("WV",$J,WVSS 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,WVS,N))
- if N=""
- QUIT
- Begin DoDot:1
- +5 SET M=0
- +6 FOR
- SET M=$ORDER(^TMP("WV",$JOB,WVS,N,M))
- if M=""
- QUIT
- Begin DoDot:2
- +7 SET P=0
- +8 FOR
- SET P=$ORDER(^TMP("WV",$JOB,WVS,N,M,P))
- if P=""
- QUIT
- Begin DoDot:3
- +9 SET I=I+1
- SET ^TMP("WV",$JOB,WVSS,I)=^TMP("WV",$JOB,WVS,N,M,P)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- DEQUEUE ;EP
- +1 ;---> CALLED BY TASKMAN
- +2 DO SETVARS^WVUTL5
- DO SORT
- DO DISPLAY
- DO EXIT
- +3 QUIT