PXQMAIN2 ;ISL/JVS - MAIN MENU ROUTINE #3 ;8/29/96 10:33
;;1.0;PCE PATIENT CARE ENCOUNTER;**4**;Aug 12, 1996
;
;--OPTION 9
N LOC9,NAME,PAT9,POP,Y
S DIR("A")="Select a Display"
S DIR(0)="SOM^P:Patient files;L:Location files"
D ^DIR I Y=""!(Y["^") G CLOSE
I Y="P" D PAT G MENU
I Y="L" D LOC G MENU
K DIR("A"),DIR(0)
G CLOSE
;
PAT ;--PATIENT FILES
;--GENERAL ERRORS IN THE DATA BASE
;--OPEN DEVICE
S OPTION="9P"
D ZIS^PXQZIS G:POP EXIT
;--RESET $X,$Y
N DX,DY S (DX,DY)=0 X ^%ZOSF("XY")
PAT9P ;--BODY
N PAT,I,PXQRECI,SSN,SSN1,FLAG1,FLAG2,FLAG3,PAT2,LOC
N PAT2,LOC4,FLAG4,FLAG5
S PXQRECI=0
I '$D(^DD(2,.09,1,800)) W $$RE^PXQUTL(" ERROR ")
I '$D(^DD(2,.09,1,800)) W $$RE^PXQUTL("** NO CROSS-REFERENCE IN FILE#2 ON SSN FIELD FOR UPDATING FILE#9000001**")
I '$D(^DD(2,.09,1,800)) W $$RE^PXQUTL("** CROSS-REFERENCE COMES WITH PATIENT/IHS SUBSET PACKAGE**"),$$RE^PXQUTL(" ")
W $$RE^PXQUTL("Compare of #2 and # 9000001 Patient files"),$$RE^PXQUTL(" ")
S PAT=$$PTFLE^PXQUTL
S PAT2="^DPT(0) = "_$G(^DPT(0)),PAT9="^AUPNPAT(0) = "_$G(^AUPNPAT(0))
W $$RE^PXQUTL(" "_PAT2),$$RE^PXQUTL(" "_PAT9)
I $P(PAT,"^",1)=$P(PAT,"^",2) W $$RE^PXQUTL(" Zero Nodes MATCH")
I $P(PAT,"^",1)'=$P(PAT,"^",2) W $$RE^PXQUTL(" Zero Nodes DO NOT Match")
W $$RE^PXQUTL(" ")
;
;
I IOST["C-" D WAIT^DICD
N PXQCNT,PXQLIMIT
S PXQCNT=0,PXQLIMIT=100
S I=0 F S I=$O(^DPT(I)) Q:I'>0 Q:PXQCNT>PXQLIMIT I '$D(^AUPNPAT(I)) D
.S PXQCNT=PXQCNT+1
.I '$G(FLAG1) W $$RE^PXQUTL("Patients in file #2 but not in #9000001"),$$RE^PXQUTL(" DFN NAME SSN") S FLAG1=1
.S NAME=$P($G(^DPT(I,0)),"^",1),SSN=$P($G(^DPT(I,0)),"^",9)
.W $$RE^PXQUTL(""""_I_""",?10,"""_$E(NAME,1,20)_""",?32,"""_SSN_"""")
W $$RE^PXQUTL(" ")
I PXQCNT>PXQLIMIT W $$RE^PXQUTL("**There are more that 100 of these so I'll quit with 100**")
W $$RE^PXQUTL(" ")
;
S I=0 F S I=$O(^AUPNPAT(I)) Q:I'>0 I '$D(^DPT(I)) D
.I '$G(FLAG2) W $$RE^PXQUTL("Patients in file #9000001 but not in #2"),$$RE^PXQUTL(" DFN NAME SSN") S FLAG2=1
.S NAME="**UNKNOWN**",SSN1=$P($G(^AUPNPAT(I,41,+$$SITE^VASITE,0)),"^",2)
.W $$RE^PXQUTL(""""_I_""",?10,"""_NAME_""",?32,"""_SSN1_"""")
W $$RE^PXQUTL(" ")
;
S I=0 F S I=$O(^DPT(I)) Q:I'>0 I $D(^AUPNPAT(I)) D
.S NAME=$P($G(^DPT(I,0)),"^",1),SSN=$P($G(^DPT(I,0)),"^",9),SSN1=$P($G(^AUPNPAT(I,41,+$$SITE^VASITE,0)),"^",2)
.I SSN'=SSN1 D
..I '$G(FLAG3) W $$RE^PXQUTL("SSN'S in #2 not equal to #9000001"),$$RE^PXQUTL(" DFN NAME #2 #9000001") S FLAG3=1
..W $$RE^PXQUTL(""""_I_""",?10,"""_$E(NAME,1,20)_""",?32,"""_SSN_""",?45,"""_SSN1_"""")
W $$RE^PXQUTL(" ")
;
;
I $P(PAT,"^",1)=$P(PAT,"^",2) D
.I '$G(FLAG1) W $$RE^PXQUTL("PATIENT file #2 and PATIENT/IHS file #9000001 are in sync.")
D READ^PXQUTL
;--CLOSE DEVICE
D ^%ZISC
I $D(ZTSK) G CLOSE
E Q
;
LOC ;--LOCATION FILES
;--GENERAL ERRORS IN THE DATA BASE
;--OPEN DEVICE
S OPTION="9L"
D ZIS^PXQZIS G:POP EXIT
;--RESET $X,$Y
N DX,DY S (DX,DY)=0 X ^%ZOSF("XY")
LOC9L ;--BODY
N PAT,I,PXQRECI,SSN,SSN1,FLAG1,FLAG2,FLAG3,PAT2,LOC
N PAT2,LOC4,FLAG4,FLAG5
S PXQRECI=0
;--location files
W $$RE^PXQUTL("Compare of #4 and # 9999999.06 location files"),$$RE^PXQUTL(" ")
S LOC=$$LCFLE^PXQUTL
S LOC4="^DIC(4,0) = "_$G(^DIC(4,0)),LOC9="^AUTTLOC(0) = "_$G(^AUTTLOC(0))
W $$RE^PXQUTL(" "_LOC4),$$RE^PXQUTL(" "_LOC9)
I $P(LOC,"^",1)=$P(LOC,"^",2) W $$RE^PXQUTL(" Zero Nodes MATCH")
I $P(LOC,"^",1)'=$P(LOC,"^",2) W $$RE^PXQUTL(" Zero Nodes DO NOT Match")
W $$RE^PXQUTL(" ")
;
;
I IOST["C-" D WAIT^DICD
;
S I=0 F S I=$O(^DIC(4,I)) Q:I'>0 I '$D(^AUTTLOC(I)) D
.I '$G(FLAG4) W $$RE^PXQUTL("Locations in file #4 but not in #9999999.06"),$$RE^PXQUTL(" IEN NAME") S FLAG4=1
.S NAME=$P($G(^DIC(4,I,0)),"^",1)
.W $$RE^PXQUTL(""""_I_""",?10,"""_NAME_"""")
W $$RE^PXQUTL(" ")
;
S I=0 F S I=$O(^AUTTLOC(I)) Q:I'>0 I '$D(^DIC(4,I)) D
.I '$G(FLAG5) W $$RE^PXQUTL("Locations in file #9999999.06 but not in #4"),$$RE^PXQUTL(" IEN NAME") S FLAG5=1
.S NAME="**UNKNOWN**"
.W $$RE^PXQUTL(""""_I_""",?10,"""_NAME_"""")
W $$RE^PXQUTL(" ")
;
I $P(LOC,"^",1)=$P(LOC,"^",2) D
.I '$G(FLAG4) W $$RE^PXQUTL("INSTITUTION file #4 and LOCATION file #9999999.06 are in sync.")
D READ^PXQUTL
;--CLOSE DEVICE
D ^%ZISC
I $D(ZTSK) G CLOSE
E Q
;
CLOSE ;--CLOSE DEVICE
D ^%ZISC
K OPTION
;--RETURN TO MENU
;R !,"Press any key to return to the menu",ANS:DTIME
Q
;
EXIT ;--EXIT
K OPTION
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXQMAIN2 4641 printed Apr 09, 2024@21:33:05 Page 2
PXQMAIN2 ;ISL/JVS - MAIN MENU ROUTINE #3 ;8/29/96 10:33
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**4**;Aug 12, 1996
+2 ;
+1 ;--OPTION 9
+2 NEW LOC9,NAME,PAT9,POP,Y
+3 SET DIR("A")="Select a Display"
+4 SET DIR(0)="SOM^P:Patient files;L:Location files"
+5 DO ^DIR
IF Y=""!(Y["^")
GOTO CLOSE
+6 IF Y="P"
DO PAT
GOTO MENU
+7 IF Y="L"
DO LOC
GOTO MENU
+8 KILL DIR("A"),DIR(0)
+9 GOTO CLOSE
+10 ;
PAT ;--PATIENT FILES
+1 ;--GENERAL ERRORS IN THE DATA BASE
+2 ;--OPEN DEVICE
+3 SET OPTION="9P"
+4 DO ZIS^PXQZIS
if POP
GOTO EXIT
+5 ;--RESET $X,$Y
+6 NEW DX,DY
SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
PAT9P ;--BODY
+1 NEW PAT,I,PXQRECI,SSN,SSN1,FLAG1,FLAG2,FLAG3,PAT2,LOC
+2 NEW PAT2,LOC4,FLAG4,FLAG5
+3 SET PXQRECI=0
+4 IF '$DATA(^DD(2,.09,1,800))
WRITE $$RE^PXQUTL(" ERROR ")
+5 IF '$DATA(^DD(2,.09,1,800))
WRITE $$RE^PXQUTL("** NO CROSS-REFERENCE IN FILE#2 ON SSN FIELD FOR UPDATING FILE#9000001**")
+6 IF '$DATA(^DD(2,.09,1,800))
WRITE $$RE^PXQUTL("** CROSS-REFERENCE COMES WITH PATIENT/IHS SUBSET PACKAGE**"),$$RE^PXQUTL(" ")
+7 WRITE $$RE^PXQUTL("Compare of #2 and # 9000001 Patient files"),$$RE^PXQUTL(" ")
+8 SET PAT=$$PTFLE^PXQUTL
+9 SET PAT2="^DPT(0) = "_$GET(^DPT(0))
SET PAT9="^AUPNPAT(0) = "_$GET(^AUPNPAT(0))
+10 WRITE $$RE^PXQUTL(" "_PAT2),$$RE^PXQUTL(" "_PAT9)
+11 IF $PIECE(PAT,"^",1)=$PIECE(PAT,"^",2)
WRITE $$RE^PXQUTL(" Zero Nodes MATCH")
+12 IF $PIECE(PAT,"^",1)'=$PIECE(PAT,"^",2)
WRITE $$RE^PXQUTL(" Zero Nodes DO NOT Match")
+13 WRITE $$RE^PXQUTL(" ")
+14 ;
+15 ;
+16 IF IOST["C-"
DO WAIT^DICD
+17 NEW PXQCNT,PXQLIMIT
+18 SET PXQCNT=0
SET PXQLIMIT=100
+19 SET I=0
FOR
SET I=$ORDER(^DPT(I))
if I'>0
QUIT
if PXQCNT>PXQLIMIT
QUIT
IF '$DATA(^AUPNPAT(I))
Begin DoDot:1
+20 SET PXQCNT=PXQCNT+1
+21 IF '$GET(FLAG1)
WRITE $$RE^PXQUTL("Patients in file #2 but not in #9000001"),$$RE^PXQUTL(" DFN NAME SSN")
SET FLAG1=1
+22 SET NAME=$PIECE($GET(^DPT(I,0)),"^",1)
SET SSN=$PIECE($GET(^DPT(I,0)),"^",9)
+23 WRITE $$RE^PXQUTL(""""_I_""",?10,"""_$EXTRACT(NAME,1,20)_""",?32,"""_SSN_"""")
End DoDot:1
+24 WRITE $$RE^PXQUTL(" ")
+25 IF PXQCNT>PXQLIMIT
WRITE $$RE^PXQUTL("**There are more that 100 of these so I'll quit with 100**")
+26 WRITE $$RE^PXQUTL(" ")
+27 ;
+28 SET I=0
FOR
SET I=$ORDER(^AUPNPAT(I))
if I'>0
QUIT
IF '$DATA(^DPT(I))
Begin DoDot:1
+29 IF '$GET(FLAG2)
WRITE $$RE^PXQUTL("Patients in file #9000001 but not in #2"),$$RE^PXQUTL(" DFN NAME SSN")
SET FLAG2=1
+30 SET NAME="**UNKNOWN**"
SET SSN1=$PIECE($GET(^AUPNPAT(I,41,+$$SITE^VASITE,0)),"^",2)
+31 WRITE $$RE^PXQUTL(""""_I_""",?10,"""_NAME_""",?32,"""_SSN1_"""")
End DoDot:1
+32 WRITE $$RE^PXQUTL(" ")
+33 ;
+34 SET I=0
FOR
SET I=$ORDER(^DPT(I))
if I'>0
QUIT
IF $DATA(^AUPNPAT(I))
Begin DoDot:1
+35 SET NAME=$PIECE($GET(^DPT(I,0)),"^",1)
SET SSN=$PIECE($GET(^DPT(I,0)),"^",9)
SET SSN1=$PIECE($GET(^AUPNPAT(I,41,+$$SITE^VASITE,0)),"^",2)
+36 IF SSN'=SSN1
Begin DoDot:2
+37 IF '$GET(FLAG3)
WRITE $$RE^PXQUTL("SSN'S in #2 not equal to #9000001"),$$RE^PXQUTL(" DFN NAME #2 #9000001")
SET FLAG3=1
+38 WRITE $$RE^PXQUTL(""""_I_""",?10,"""_$EXTRACT(NAME,1,20)_""",?32,"""_SSN_""",?45,"""_SSN1_"""")
End DoDot:2
End DoDot:1
+39 WRITE $$RE^PXQUTL(" ")
+40 ;
+41 ;
+42 IF $PIECE(PAT,"^",1)=$PIECE(PAT,"^",2)
Begin DoDot:1
+43 IF '$GET(FLAG1)
WRITE $$RE^PXQUTL("PATIENT file #2 and PATIENT/IHS file #9000001 are in sync.")
End DoDot:1
+44 DO READ^PXQUTL
+45 ;--CLOSE DEVICE
+46 DO ^%ZISC
+47 IF $DATA(ZTSK)
GOTO CLOSE
+48 IF '$TEST
QUIT
+49 ;
LOC ;--LOCATION FILES
+1 ;--GENERAL ERRORS IN THE DATA BASE
+2 ;--OPEN DEVICE
+3 SET OPTION="9L"
+4 DO ZIS^PXQZIS
if POP
GOTO EXIT
+5 ;--RESET $X,$Y
+6 NEW DX,DY
SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
LOC9L ;--BODY
+1 NEW PAT,I,PXQRECI,SSN,SSN1,FLAG1,FLAG2,FLAG3,PAT2,LOC
+2 NEW PAT2,LOC4,FLAG4,FLAG5
+3 SET PXQRECI=0
+4 ;--location files
+5 WRITE $$RE^PXQUTL("Compare of #4 and # 9999999.06 location files"),$$RE^PXQUTL(" ")
+6 SET LOC=$$LCFLE^PXQUTL
+7 SET LOC4="^DIC(4,0) = "_$GET(^DIC(4,0))
SET LOC9="^AUTTLOC(0) = "_$GET(^AUTTLOC(0))
+8 WRITE $$RE^PXQUTL(" "_LOC4),$$RE^PXQUTL(" "_LOC9)
+9 IF $PIECE(LOC,"^",1)=$PIECE(LOC,"^",2)
WRITE $$RE^PXQUTL(" Zero Nodes MATCH")
+10 IF $PIECE(LOC,"^",1)'=$PIECE(LOC,"^",2)
WRITE $$RE^PXQUTL(" Zero Nodes DO NOT Match")
+11 WRITE $$RE^PXQUTL(" ")
+12 ;
+13 ;
+14 IF IOST["C-"
DO WAIT^DICD
+15 ;
+16 SET I=0
FOR
SET I=$ORDER(^DIC(4,I))
if I'>0
QUIT
IF '$DATA(^AUTTLOC(I))
Begin DoDot:1
+17 IF '$GET(FLAG4)
WRITE $$RE^PXQUTL("Locations in file #4 but not in #9999999.06"),$$RE^PXQUTL(" IEN NAME")
SET FLAG4=1
+18 SET NAME=$PIECE($GET(^DIC(4,I,0)),"^",1)
+19 WRITE $$RE^PXQUTL(""""_I_""",?10,"""_NAME_"""")
End DoDot:1
+20 WRITE $$RE^PXQUTL(" ")
+21 ;
+22 SET I=0
FOR
SET I=$ORDER(^AUTTLOC(I))
if I'>0
QUIT
IF '$DATA(^DIC(4,I))
Begin DoDot:1
+23 IF '$GET(FLAG5)
WRITE $$RE^PXQUTL("Locations in file #9999999.06 but not in #4"),$$RE^PXQUTL(" IEN NAME")
SET FLAG5=1
+24 SET NAME="**UNKNOWN**"
+25 WRITE $$RE^PXQUTL(""""_I_""",?10,"""_NAME_"""")
End DoDot:1
+26 WRITE $$RE^PXQUTL(" ")
+27 ;
+28 IF $PIECE(LOC,"^",1)=$PIECE(LOC,"^",2)
Begin DoDot:1
+29 IF '$GET(FLAG4)
WRITE $$RE^PXQUTL("INSTITUTION file #4 and LOCATION file #9999999.06 are in sync.")
End DoDot:1
+30 DO READ^PXQUTL
+31 ;--CLOSE DEVICE
+32 DO ^%ZISC
+33 IF $DATA(ZTSK)
GOTO CLOSE
+34 IF '$TEST
QUIT
+35 ;
CLOSE ;--CLOSE DEVICE
+1 DO ^%ZISC
+2 KILL OPTION
+3 ;--RETURN TO MENU
+4 ;R !,"Press any key to return to the menu",ANS:DTIME
+5 QUIT
+6 ;
EXIT ;--EXIT
+1 KILL OPTION
+2 QUIT
