WVRPSNP ;HCIOFO/FT,JR - REPORT: SNAPSHOT OF PROGRAM;05/24/2017  14:32
 ;;1.0;WOMEN'S HEALTH;**7,8,24**;Sep 30, 1998;Build 582
 ;;  Original routine created by IHS/ANMC/MWR
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  CALLED BY OPTION: "WV PRINT SNAPSHOT" TO DISPLAY FROM 1/1 CURRENT
 ;;  YEAR TO PRESENT #PATIENTS, #PAPS, #MAMS, #DELINQUENT NEEDS, ETC.
 ;
 D SETVARS^WVUTL5 S WVFAC=DUZ(2) K ^TMP("WVF",$J)
 N A,B,C,D,E,F,G,H,I,J,K,L,M,N,P,Q,R,S,X,Y,WA,WB,WC,WE,WF,WG,WH,WX,N0
 N WVBRTXND,WVCXTXND
 D TITLE^WVUTL5("PROGRAM SNAPSHOT")
 D ASKTOY G:WVPOP EXIT
 D ASKSAVE G:WVPOP EXIT
 D DEVICE  G:WVPOP EXIT
 D GATHER
 D:WVA STORE
 K WVDTIEN
 D ^WVRPSNP1
 ;
EXIT ;EP
 D KILLALL^WVUTL8
 K ^TMP("WVF",$J)
 Q
 ;
ASKTOY ;
 S WVTOY="" S DIR("A")="   Report by (C)alendar or (F)iscal year? "
 S DIR(0)="SAO^C:Calendar Year;F:Fiscal Year",DIR("B")="Fiscal"
 D ^DIR
 I "FC"'[Y S WVPOP=1 Q
 S WVTOY=Y
 S WVJDT=$E(DT,1,3)_"0000"
 I WVTOY="C" Q
 I $E(DT,4,5)<10 S WVJDT=$E(DT-10000,1,3)_"1000" Q
 S WVJDT=$E(DT,1,3)_"1000"
 Q
DEVICE ;EP
 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
 S ZTRTN="DEQUEUE^WVRPSNP"
 F WVSV="A","FAC","TOY","JDT" D
 .I $D(@("WV"_WVSV)) S ZTSAVE("WV"_WVSV)=""
 D ZIS^WVUTL2(.WVPOP,1,"HOME")
 Q
 ;
ASKSAVE ;EP
 ;---> ASK IF THIS REPORT SHOULD BE SAVED FOR LATER RETRIEVAL.
 N DIR,DIRUT,Y
 W !!?3,"Should today's Snapshot be stored for later retrieval and"
 W " comparisons?"
 S DIR(0)="Y",DIR("A")="   Enter Yes or No",DIR("B")="NO"
 S WVA=0 D HELP1
 D ^DIR K DIR W !
 S:$D(DIRUT) WVPOP=1
 S:Y WVA=1
 Q
 ;
DEQUEUE ;EP
 ;---> QUEUED REPORT
 N A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S,X,Y
 D SETVARS^WVUTL5,GATHER,STORE,^WVRPSNP1,EXIT
 Q
 ;
STORE ;EP
 ;---> STORE REPORT DATA IN FILE #790.71.
 Q:'WVA
 N WVDR,DA,DIC,DIE,X,Y
 S WVDR=".02////"_WVFAC,Y=.02
 F WVI=A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R D
 .S Y=Y+.01,WVDR=WVDR_";"_Y_"////"_WVI
 S Y=.5,WVJDR=".5////"_WVI(1)
 F WVJ=2:1:30 S Y=Y+.01 S WVJDR=WVJDR_";"_Y_"////"_WVI(WVJ)
 S WVDR=WVDR_";.18////"_WVTOY
 N A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R D
 .S A=0,WVJNDA="" F  S A=$O(^WV(790.71,"B",DT,A)) Q:A'>0  D  Q:WVJNDA>0
 ..S:$D(^WV(790.71,"T",WVTOY,A)) WVJNDA=A
 .I WVJNDA'>0 D 
 ..K DD,DO S DIC="^WV(790.71,",DIC(0)="ML",X=DT
 ..D FILE^DICN Q:Y<0  S WVJNDA=+Y
 .S Y=$G(WVJNDA) Q:Y'>0
 .D DIE^WVFMAN(790.71,WVDR,WVJNDA)
 .D DIE^WVFMAN(790.71,WVJDR,WVJNDA)
 Q
 ;
 ;
GATHER ;EP
 ;---> GATHER DATA
 S (A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S)=0
 ;---> USE WVDT SO THAT THE DATE WON'T CHANGE IF RUN SPANS MIDNIGHT.
 D SETVARS^WVUTL5 S WVDT=DT
 S WVBRTXND=$$IEN^WVUTL9(790.51,"Not Indicated")
 S WVCXTXND=$$IEN^WVUTL9(790.5,"Not Indicated")
 ;
 ;---> PATIENT DATA
 F  S N=$O(^WV(790,N)) Q:'N  S Y=^WV(790,N,0) D
 .;---> QUIT IF PATIENT IS NOT ACTIVE.
 .Q:$P(Y,U,24)
 .;---> QUIT IF PATIENT IS DECEASED.
 .Q:$$DECEASED^WVUTL1($P(Y,U))
 .;---> TOTAL ACTIVE WOMEN IN REGISTER.
 .S A=A+1
 .;---> WOMEN PREGNANT.
 .I $$ISPREG^WVUTL11(N) S B=B+1
 .;---> DES DAUGHTERS.
 .S:$P(Y,U,15) C=C+1
 .;---> WOMEN WITH CERVICAL TX NEEDS NOT SPECIFIED OR NOT DATED.
 .;     Don't count if need is "Not Indicated"
 .I ($P(Y,U,11)'=WVCXTXND) I 5[$P(Y,U,11)!('$P(Y,U,12)) S D=D+1
 .;---> IF DATE DUE=NULL IT WAS COUNTED LINE ABOVE, SO DON'T COUNT
 .;---> IT IN THE LINE BELOW: +$P(Y,U,19).
 .;---> WOMEN WITH CERVICAL TX NEEDS SPECIFIED AND PAST DUE.
 .I ($P(Y,U,11)'=WVCXTXND) I 5'[$P(Y,U,11)&($P(Y,U,12)<WVDT)&(+$P(Y,U,12)) S E=E+1
 .;---> WOMEN WITH BREAST TX NEEDS NOT SPECIFIED OR NOT DATED.
 .;     Don't count if need is "Not Indicated"
 .I ($P(Y,U,18)'=WVBRTXND) I 8[$P(Y,U,18)!('$P(Y,U,19)) S F=F+1
 .;---> WOMEN WITH BREAST TX NEEDS SPECIFIED AND PAST DUE.
 .I ($P(Y,U,18)'=WVBRTXND) I 8'[$P(Y,U,18)&($P(Y,U,19)<WVDT)&(+$P(Y,U,19)) S G=G+1
 ;
 ;---> PROCEDURE DATA
 S N=0
 F  S N=$O(^WV(790.1,"S","o",N)) Q:'N  S Y=^WV(790.1,N,0) D
 .Q:"o"'[$P(Y,U,14)
 .Q:$P(Y,U,5)=8
 .S H=H+1 S:$P(Y,U,13)<WVDT S=S+1
 ;
 ;---> TOTAL PAPS, CBES, AND MAMS FOR THIS YEAR (SINCE JAN 1, OR FISCAL).
 S N=WVJDT,WVENDDT1=WVDT+.9999
 F  S N=$O(^WV(790.1,"D",N)) Q:'N!(N>WVENDDT1)  D
 .S M=0
 .F  S M=$O(^WV(790.1,"D",N,M)) Q:'M  S Y=^WV(790.1,M,0) D
 ..;---> BELOW IS HARD CODED FOR IENS IN ^WV(790.2, (PAP, CBE, OR MAM) AND
 ..;---> ^WV(790.31, (ERROR/DISREGARD).  COULD BE MORE ROBUST BY LOOKING
 ..;---> AT #.10 FIELD OF ^WV(790.2 AND #.23 FIELD OF ^WV(790.31,.
 ..Q:$P(Y,U,5)=8
 ..I $P(Y,U,4)=1 S P=P+1 Q                                    ;---> PAP
 ..I $P(Y,U,4)=25!($P(Y,U,4)=26)!($P(Y,U,4)=28) S Q=Q+1 Q     ;---> MAM
 ..I $P(Y,U,4)=27 S R=R+1                                     ;---> CBE
 ;
 ;---> NOTIFICATION DATA
 S N=0
 F  S N=$O(^WV(790.4,"AOPEN",N)) Q:'N  D
 .S M=0
 .F  S M=$O(^WV(790.4,"AOPEN",N,M)) Q:'M  D
 ..I '$D(^WV(790.4,M,0)) K ^WV(790.4,"AOPEN",N,M) Q
 ..S Y=^WV(790.4,M,0)
 ..S:$P(Y,U,14)="o" J=J+1
 ..S:$P(Y,U,14)="o"&($P(Y,U,13)<WVDT) K=K+1
 ;---> LETTERS QUEUED
 S N=0 F  S N=$O(^WV(790.4,"APRT",N)) Q:'N  D
 .S M=0 F  S M=$O(^WV(790.4,"APRT",N,M)) Q:'M  S L=L+1
R ;---> TREATMENT REFUSALS
 N WVREFPCE
 ;piece # and its value form a link for refusal counts
 ; (e.g., piece 1 has a value of 24). Entry #1 in File 790.2 is Pap Smear
 ; and the # of refused Pap Smears is stored in piece 24 (of node 2) 
 ; in File 790.71.
 S WVREFPCE="24^4^13^6^^^7^9^^^^^^^^^16^8^5^25^26^14^15^12^18^19^2^20^11^22^23^17^21^10^27^^3^1^28^29^30"
 F WA=1:1:41 D
 .S WB=$P(WVREFPCE,U,WA)
 .Q:'WB
 .S WVI(WB)=0
 S WA=WVJDT F  S WA=$O(^WV(790.3,"B",WA)) Q:WA'>0  D
 .S WB=0 F  S WB=$O(^WV(790.3,"B",WA,WB)) Q:WB'>0  D
 ..S N0=$G(^WV(790.3,WB,0))
 ..N P1 F P1=1,2,3,4 S P1(P1)=$P(N0,U,P1) S:P1(P1)="" P1(P1)="NOT ENTERED"
 ..Q:'P1(3)
 ..S WVCN=+$P(WVREFPCE,U,+P1(3)) Q:'WVCN
 ..S WVI(WVCN)=WVI(WVCN)+1
 Q
 ;
 ;
HELP1 ;EP
 ;;Answer "YES" to store the results of today's snapshot after they
 ;;have been printed out.  These results can then be retrieved in the
 ;;future (by calling up today's date) and compared to other Snapshots
 ;;in order to look at the trends and progress of your program over
 ;;time. (Note: If a previous snapshot for today has been run, it will
 ;;be overwritten by this or any later run today.)
 ;;
 ;;Answer "NO" to simply print today's Snapshot without storing it.
 S WVTAB=5,WVLINL="HELP1" D HELPTX
 Q
 ;
HELPTX ;EP
 N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
 F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;"  S DIR("?",I)=T_$P(X,";;",2)
 S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
 Q
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPSNP   6504     printed  Sep 23, 2025@20:24:16                                                                                                                                                                                                     Page 2
WVRPSNP   ;HCIOFO/FT,JR - REPORT: SNAPSHOT OF PROGRAM;05/24/2017  14:32
 +1       ;;1.0;WOMEN'S HEALTH;**7,8,24**;Sep 30, 1998;Build 582
 +2       ;;  Original routine created by IHS/ANMC/MWR
 +3       ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 +4       ;;  CALLED BY OPTION: "WV PRINT SNAPSHOT" TO DISPLAY FROM 1/1 CURRENT
 +5       ;;  YEAR TO PRESENT #PATIENTS, #PAPS, #MAMS, #DELINQUENT NEEDS, ETC.
 +6       ;
 +7        DO SETVARS^WVUTL5
           SET WVFAC=DUZ(2)
           KILL ^TMP("WVF",$JOB)
 +8        NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,P,Q,R,S,X,Y,WA,WB,WC,WE,WF,WG,WH,WX,N0
 +9        NEW WVBRTXND,WVCXTXND
 +10       DO TITLE^WVUTL5("PROGRAM SNAPSHOT")
 +11       DO ASKTOY
           if WVPOP
               GOTO EXIT
 +12       DO ASKSAVE
           if WVPOP
               GOTO EXIT
 +13       DO DEVICE
           if WVPOP
               GOTO EXIT
 +14       DO GATHER
 +15       if WVA
               DO STORE
 +16       KILL WVDTIEN
 +17       DO ^WVRPSNP1
 +18      ;
EXIT      ;EP
 +1        DO KILLALL^WVUTL8
 +2        KILL ^TMP("WVF",$JOB)
 +3        QUIT 
 +4       ;
ASKTOY    ;
 +1        SET WVTOY=""
           SET DIR("A")="   Report by (C)alendar or (F)iscal year? "
 +2        SET DIR(0)="SAO^C:Calendar Year;F:Fiscal Year"
           SET DIR("B")="Fiscal"
 +3        DO ^DIR
 +4        IF "FC"'[Y
               SET WVPOP=1
               QUIT 
 +5        SET WVTOY=Y
 +6        SET WVJDT=$EXTRACT(DT,1,3)_"0000"
 +7        IF WVTOY="C"
               QUIT 
 +8        IF $EXTRACT(DT,4,5)<10
               SET WVJDT=$EXTRACT(DT-10000,1,3)_"1000"
               QUIT 
 +9        SET WVJDT=$EXTRACT(DT,1,3)_"1000"
 +10       QUIT 
DEVICE    ;EP
 +1       ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
 +2        SET ZTRTN="DEQUEUE^WVRPSNP"
 +3        FOR WVSV="A","FAC","TOY","JDT"
               Begin DoDot:1
 +4                IF $DATA(@("WV"_WVSV))
                       SET ZTSAVE("WV"_WVSV)=""
               End DoDot:1
 +5        DO ZIS^WVUTL2(.WVPOP,1,"HOME")
 +6        QUIT 
 +7       ;
ASKSAVE   ;EP
 +1       ;---> ASK IF THIS REPORT SHOULD BE SAVED FOR LATER RETRIEVAL.
 +2        NEW DIR,DIRUT,Y
 +3        WRITE !!?3,"Should today's Snapshot be stored for later retrieval and"
 +4        WRITE " comparisons?"
 +5        SET DIR(0)="Y"
           SET DIR("A")="   Enter Yes or No"
           SET DIR("B")="NO"
 +6        SET WVA=0
           DO HELP1
 +7        DO ^DIR
           KILL DIR
           WRITE !
 +8        if $DATA(DIRUT)
               SET WVPOP=1
 +9        if Y
               SET WVA=1
 +10       QUIT 
 +11      ;
DEQUEUE   ;EP
 +1       ;---> QUEUED REPORT
 +2        NEW A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S,X,Y
 +3        DO SETVARS^WVUTL5
           DO GATHER
           DO STORE
           DO ^WVRPSNP1
           DO EXIT
 +4        QUIT 
 +5       ;
STORE     ;EP
 +1       ;---> STORE REPORT DATA IN FILE #790.71.
 +2        if 'WVA
               QUIT 
 +3        NEW WVDR,DA,DIC,DIE,X,Y
 +4        SET WVDR=".02////"_WVFAC
           SET Y=.02
 +5        FOR WVI=A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R
               Begin DoDot:1
 +6                SET Y=Y+.01
                   SET WVDR=WVDR_";"_Y_"////"_WVI
               End DoDot:1
 +7        SET Y=.5
           SET WVJDR=".5////"_WVI(1)
 +8        FOR WVJ=2:1:30
               SET Y=Y+.01
               SET WVJDR=WVJDR_";"_Y_"////"_WVI(WVJ)
 +9        SET WVDR=WVDR_";.18////"_WVTOY
 +10       NEW A,B,C,D,E,F,G,H,S,J,K,L,P,Q,R
           Begin DoDot:1
 +11           SET A=0
               SET WVJNDA=""
               FOR 
                   SET A=$ORDER(^WV(790.71,"B",DT,A))
                   if A'>0
                       QUIT 
                   Begin DoDot:2
 +12                   if $DATA(^WV(790.71,"T",WVTOY,A))
                           SET WVJNDA=A
                   End DoDot:2
                   if WVJNDA>0
                       QUIT 
 +13           IF WVJNDA'>0
                   Begin DoDot:2
 +14                   KILL DD,DO
                       SET DIC="^WV(790.71,"
                       SET DIC(0)="ML"
                       SET X=DT
 +15                   DO FILE^DICN
                       if Y<0
                           QUIT 
                       SET WVJNDA=+Y
                   End DoDot:2
 +16           SET Y=$GET(WVJNDA)
               if Y'>0
                   QUIT 
 +17           DO DIE^WVFMAN(790.71,WVDR,WVJNDA)
 +18           DO DIE^WVFMAN(790.71,WVJDR,WVJNDA)
           End DoDot:1
 +19       QUIT 
 +20      ;
 +21      ;
GATHER    ;EP
 +1       ;---> GATHER DATA
 +2        SET (A,B,C,D,E,F,G,H,J,K,L,M,N,P,Q,R,S)=0
 +3       ;---> USE WVDT SO THAT THE DATE WON'T CHANGE IF RUN SPANS MIDNIGHT.
 +4        DO SETVARS^WVUTL5
           SET WVDT=DT
 +5        SET WVBRTXND=$$IEN^WVUTL9(790.51,"Not Indicated")
 +6        SET WVCXTXND=$$IEN^WVUTL9(790.5,"Not Indicated")
 +7       ;
 +8       ;---> PATIENT DATA
 +9        FOR 
               SET N=$ORDER(^WV(790,N))
               if 'N
                   QUIT 
               SET Y=^WV(790,N,0)
               Begin DoDot:1
 +10      ;---> QUIT IF PATIENT IS NOT ACTIVE.
 +11               if $PIECE(Y,U,24)
                       QUIT 
 +12      ;---> QUIT IF PATIENT IS DECEASED.
 +13               if $$DECEASED^WVUTL1($PIECE(Y,U))
                       QUIT 
 +14      ;---> TOTAL ACTIVE WOMEN IN REGISTER.
 +15               SET A=A+1
 +16      ;---> WOMEN PREGNANT.
 +17               IF $$ISPREG^WVUTL11(N)
                       SET B=B+1
 +18      ;---> DES DAUGHTERS.
 +19               if $PIECE(Y,U,15)
                       SET C=C+1
 +20      ;---> WOMEN WITH CERVICAL TX NEEDS NOT SPECIFIED OR NOT DATED.
 +21      ;     Don't count if need is "Not Indicated"
 +22               IF ($PIECE(Y,U,11)'=WVCXTXND)
                       IF 5[$PIECE(Y,U,11)!('$PIECE(Y,U,12))
                           SET D=D+1
 +23      ;---> IF DATE DUE=NULL IT WAS COUNTED LINE ABOVE, SO DON'T COUNT
 +24      ;---> IT IN THE LINE BELOW: +$P(Y,U,19).
 +25      ;---> WOMEN WITH CERVICAL TX NEEDS SPECIFIED AND PAST DUE.
 +26               IF ($PIECE(Y,U,11)'=WVCXTXND)
                       IF 5'[$PIECE(Y,U,11)&($PIECE(Y,U,12)<WVDT)&(+$PIECE(Y,U,12))
                           SET E=E+1
 +27      ;---> WOMEN WITH BREAST TX NEEDS NOT SPECIFIED OR NOT DATED.
 +28      ;     Don't count if need is "Not Indicated"
 +29               IF ($PIECE(Y,U,18)'=WVBRTXND)
                       IF 8[$PIECE(Y,U,18)!('$PIECE(Y,U,19))
                           SET F=F+1
 +30      ;---> WOMEN WITH BREAST TX NEEDS SPECIFIED AND PAST DUE.
 +31               IF ($PIECE(Y,U,18)'=WVBRTXND)
                       IF 8'[$PIECE(Y,U,18)&($PIECE(Y,U,19)<WVDT)&(+$PIECE(Y,U,19))
                           SET G=G+1
               End DoDot:1
 +32      ;
 +33      ;---> PROCEDURE DATA
 +34       SET N=0
 +35       FOR 
               SET N=$ORDER(^WV(790.1,"S","o",N))
               if 'N
                   QUIT 
               SET Y=^WV(790.1,N,0)
               Begin DoDot:1
 +36               if "o"'[$PIECE(Y,U,14)
                       QUIT 
 +37               if $PIECE(Y,U,5)=8
                       QUIT 
 +38               SET H=H+1
                   if $PIECE(Y,U,13)<WVDT
                       SET S=S+1
               End DoDot:1
 +39      ;
 +40      ;---> TOTAL PAPS, CBES, AND MAMS FOR THIS YEAR (SINCE JAN 1, OR FISCAL).
 +41       SET N=WVJDT
           SET WVENDDT1=WVDT+.9999
 +42       FOR 
               SET N=$ORDER(^WV(790.1,"D",N))
               if 'N!(N>WVENDDT1)
                   QUIT 
               Begin DoDot:1
 +43               SET M=0
 +44               FOR 
                       SET M=$ORDER(^WV(790.1,"D",N,M))
                       if 'M
                           QUIT 
                       SET Y=^WV(790.1,M,0)
                       Begin DoDot:2
 +45      ;---> BELOW IS HARD CODED FOR IENS IN ^WV(790.2, (PAP, CBE, OR MAM) AND
 +46      ;---> ^WV(790.31, (ERROR/DISREGARD).  COULD BE MORE ROBUST BY LOOKING
 +47      ;---> AT #.10 FIELD OF ^WV(790.2 AND #.23 FIELD OF ^WV(790.31,.
 +48                       if $PIECE(Y,U,5)=8
                               QUIT 
 +49      ;---> PAP
                           IF $PIECE(Y,U,4)=1
                               SET P=P+1
                               QUIT 
 +50      ;---> MAM
                           IF $PIECE(Y,U,4)=25!($PIECE(Y,U,4)=26)!($PIECE(Y,U,4)=28)
                               SET Q=Q+1
                               QUIT 
 +51      ;---> CBE
                           IF $PIECE(Y,U,4)=27
                               SET R=R+1
                       End DoDot:2
               End DoDot:1
 +52      ;
 +53      ;---> NOTIFICATION DATA
 +54       SET N=0
 +55       FOR 
               SET N=$ORDER(^WV(790.4,"AOPEN",N))
               if 'N
                   QUIT 
               Begin DoDot:1
 +56               SET M=0
 +57               FOR 
                       SET M=$ORDER(^WV(790.4,"AOPEN",N,M))
                       if 'M
                           QUIT 
                       Begin DoDot:2
 +58                       IF '$DATA(^WV(790.4,M,0))
                               KILL ^WV(790.4,"AOPEN",N,M)
                               QUIT 
 +59                       SET Y=^WV(790.4,M,0)
 +60                       if $PIECE(Y,U,14)="o"
                               SET J=J+1
 +61                       if $PIECE(Y,U,14)="o"&($PIECE(Y,U,13)<WVDT)
                               SET K=K+1
                       End DoDot:2
               End DoDot:1
 +62      ;---> LETTERS QUEUED
 +63       SET N=0
           FOR 
               SET N=$ORDER(^WV(790.4,"APRT",N))
               if 'N
                   QUIT 
               Begin DoDot:1
 +64               SET M=0
                   FOR 
                       SET M=$ORDER(^WV(790.4,"APRT",N,M))
                       if 'M
                           QUIT 
                       SET L=L+1
               End DoDot:1
R         ;---> TREATMENT REFUSALS
 +1        NEW WVREFPCE
 +2       ;piece # and its value form a link for refusal counts
 +3       ; (e.g., piece 1 has a value of 24). Entry #1 in File 790.2 is Pap Smear
 +4       ; and the # of refused Pap Smears is stored in piece 24 (of node 2) 
 +5       ; in File 790.71.
 +6        SET WVREFPCE="24^4^13^6^^^7^9^^^^^^^^^16^8^5^25^26^14^15^12^18^19^2^20^11^22^23^17^21^10^27^^3^1^28^29^30"
 +7        FOR WA=1:1:41
               Begin DoDot:1
 +8                SET WB=$PIECE(WVREFPCE,U,WA)
 +9                if 'WB
                       QUIT 
 +10               SET WVI(WB)=0
               End DoDot:1
 +11       SET WA=WVJDT
           FOR 
               SET WA=$ORDER(^WV(790.3,"B",WA))
               if WA'>0
                   QUIT 
               Begin DoDot:1
 +12               SET WB=0
                   FOR 
                       SET WB=$ORDER(^WV(790.3,"B",WA,WB))
                       if WB'>0
                           QUIT 
                       Begin DoDot:2
 +13                       SET N0=$GET(^WV(790.3,WB,0))
 +14                       NEW P1
                           FOR P1=1,2,3,4
                               SET P1(P1)=$PIECE(N0,U,P1)
                               if P1(P1)=""
                                   SET P1(P1)="NOT ENTERED"
 +15                       if 'P1(3)
                               QUIT 
 +16                       SET WVCN=+$PIECE(WVREFPCE,U,+P1(3))
                           if 'WVCN
                               QUIT 
 +17                       SET WVI(WVCN)=WVI(WVCN)+1
                       End DoDot:2
               End DoDot:1
 +18       QUIT 
 +19      ;
 +20      ;
HELP1     ;EP
 +1       ;;Answer "YES" to store the results of today's snapshot after they
 +2       ;;have been printed out.  These results can then be retrieved in the
 +3       ;;future (by calling up today's date) and compared to other Snapshots
 +4       ;;in order to look at the trends and progress of your program over
 +5       ;;time. (Note: If a previous snapshot for today has been run, it will
 +6       ;;be overwritten by this or any later run today.)
 +7       ;;
 +8       ;;Answer "NO" to simply print today's Snapshot without storing it.
 +9        SET WVTAB=5
           SET WVLINL="HELP1"
           DO HELPTX
 +10       QUIT 
 +11      ;
HELPTX    ;EP
 +1        NEW I,T,X
           SET T=$$REPEAT^XLFSTR(" ",WVTAB)
 +2        FOR I=1:1
               SET X=$TEXT(@WVLINL+I)
               if X'[";;"
                   QUIT 
               SET DIR("?",I)=T_$PIECE(X,";;",2)
 +3        SET DIR("?")=DIR("?",I-1)
           KILL DIR("?",I-1)
 +4        QUIT