AG7P2A ;IHS/SD/EFG - Patient Registration 7.0 Patch 2 CONT. ; [ 06/17/2003 10:49 AM ]
;;7.0;IHS PATIENT REGISTRATION;**1,2,3**;MAR 28, 2003
;
;
PRE ;EP - From KIDS.
Q
;
POST ;EP - From KIDS.
;
D BMES^XPDUTL("Beginning post-install routine (POST^AG7P2A)."),TS
;
D ^AGSETPRT
;
D AGFAC
;
D PRVT
;
D ^AGMCDCNT
;
D MCD
;
I $$INSTALLD^AG7P2("AG*7.0*2") D
. D TS,BMES^XPDUTL("Delivering AG*7.0*2 install message to select users ...")
. D MAIL
. D BMES^XPDUTL("Post-install routine is complete."),TS
;
Q:$$INSTALLD^AG7P2("AG*7.0*2")
;
D TS,OPTRES("AGMENU")
;
D TS,BMES^XPDUTL("Delivering AG*7.0*2 install message to select users...")
;
D MAIL
;
D BMES^XPDUTL("Post-install routine is complete."),TS
Q
;
MAIL ; Send install mail message.
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("AG7P2MS",$J)
S ^TMP("AG7P2MS",$J,1)=" --- AG v 7.0, Patch 2 has been installed into this uci ---"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("AG7P2MS",$J,(%+1))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AG7P2MS"",$J,",XMY(1)="",XMY(DUZ)=""
F %="AGZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("AG7P2MS",$J)
Q
;
SINGLE(K) ;EP - Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
OPTRES(AGM) ;
D BMES^XPDUTL("Restoring '"_AGM_"' option to PRE-install configuration...")
NEW AG,AGI
I '$D(^XTMP("AG7P2",7.2,"OPTSAV",AGM)) D BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.") Q
S AG=0
F S AG=$O(^XTMP("AG7P2",7.2,"OPTSAV",AGM,AG)) Q:'AG S AGI=^(AG) I '$$ADD^XPDMENU(AGM,$P(AGI,U,1),$P(AGI,U,2),$P(AGI,U,3)) D BMES^XPDUTL("....FAILED to re-atch "_$P(AGI,U,1)_" to "_AGM_".")
D BMES^XPDUTL("Attaching ""RHI1"" option to the Registration Reports menu ""RPT"".")
I $$ADD^XPDMENU("AGREPORTS","AGRHI1","RHI1",20) D BMES^XPDUTL("....successfully atch'd.") I 1
E D BMES^XPDUTL("....Attachment *FAILED*.")
;
Q
;
TS D MES^XPDUTL($$HTE^XLFDT($H)) Q
;
AGFAC ; FEED NEW REGISTRATION PARAMETERS IF BLANK
S AGFAC=0
F S AGFAC=$O(^AGFAC("B",AGFAC)) Q:'AGFAC D
. S AGFACPTR=0
. F S AGFACPTR=$O(^AGFAC("B",AGFAC,AGFACPTR)) Q:'AGFACPTR D
.. I $P($G(^AGFAC(AGFACPTR,0)),U,22)="" S $P(^AGFAC(AGFACPTR,0),U,22)=0
.. I $P($G(^AGFAC(AGFACPTR,0)),U,23)="" S $P(^AGFAC(AGFACPTR,0),U,23)="N"
.. I $P($G(^AGFAC(AGFACPTR,0)),U,24)="" S $P(^AGFAC(AGFACPTR,0),U,24)="N"
K AGFAC,AGFACPTR
Q
PRVT ; FIND ANY PRIVATE ELIG MISSING INSURER POINTER
S RECNO=0
F S RECNO=$O(^AUPNPRVT(RECNO)) Q:'RECNO D
. S D1=0
. F S D1=$O(^AUPNPRVT(RECNO,11,D1)) Q:'D1 D
.. I $P($G(^AUPNPRVT(RECNO,11,D1,0)),U,1)="" D
... K ^AUPNPRVT(RECNO,11,D1,0)
Q
MCD ; FIND MCD MISSING .01 FIELD
S RECNO=0
F S RECNO=$O(^AUPNMCD(RECNO)) Q:'RECNO D
. S MCDREC=$G(^AUPNMCD(RECNO,0))
. I $P(MCDREC,U,1)="" K ^AUPNMCD(RECNO,0)
Q
AG7P2A ;IHS/SD/EFG - Patient Registration 7.0 Patch 2 CONT. ; [ 06/17/2003 10:49 AM ]
+1 ;;7.0;IHS PATIENT REGISTRATION;**1,2,3**;MAR 28, 2003
+2 ;
+3 ;
PRE ;EP - From KIDS.
+1 QUIT
+2 ;
POST ;EP - From KIDS.
+1 ;
+2 DO BMES^XPDUTL("Beginning post-install routine (POST^AG7P2A).")
DO TS
+3 ;
+4 DO ^AGSETPRT
+5 ;
+6 DO AGFAC
+7 ;
+8 DO PRVT
+9 ;
+10 DO ^AGMCDCNT
+11 ;
+12 DO MCD
+13 ;
+14 IF $$INSTALLD^AG7P2("AG*7.0*2")
Begin DoDot:1
+15 DO TS
DO BMES^XPDUTL("Delivering AG*7.0*2 install message to select users ...")
+16 DO MAIL
+17 DO BMES^XPDUTL("Post-install routine is complete.")
DO TS
End DoDot:1
+18 ;
+19 IF $$INSTALLD^AG7P2("AG*7.0*2")
QUIT
+20 ;
+21 DO TS
DO OPTRES("AGMENU")
+22 ;
+23 DO TS
DO BMES^XPDUTL("Delivering AG*7.0*2 install message to select users...")
+24 ;
+25 DO MAIL
+26 ;
+27 DO BMES^XPDUTL("Post-install routine is complete.")
DO TS
+28 QUIT
+29 ;
MAIL ; Send install mail message.
+1 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+2 KILL ^TMP("AG7P2MS",$JOB)
+3 SET ^TMP("AG7P2MS",$JOB,1)=" --- AG v 7.0, Patch 2 has been installed into this uci ---"
+4 SET %=0
+5 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("AG7P2MS",$JOB,(%+1))=" "_^(%,0)
+6 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AG7P2MS"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+7 FOR %="AGZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+8 DO ^XMD
+9 KILL ^TMP("AG7P2MS",$JOB)
+10 QUIT
+11 ;
SINGLE(K) ;EP - Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
OPTRES(AGM) ;
+1 DO BMES^XPDUTL("Restoring '"_AGM_"' option to PRE-install configuration...")
+2 NEW AG,AGI
+3 IF '$DATA(^XTMP("AG7P2",7.2,"OPTSAV",AGM))
DO BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.")
QUIT
+4 SET AG=0
+5 FOR
SET AG=$ORDER(^XTMP("AG7P2",7.2,"OPTSAV",AGM,AG))
IF 'AG
QUIT
SET AGI=^(AG)
IF '$$ADD^XPDMENU(AGM,$PIECE(AGI,U,1),$PIECE(AGI,U,2),$PIECE(AGI,U,3))
DO BMES^XPDUTL("....FAILED to re-atch "_$PIECE(AGI,U,1)_" to "_AGM_".")
+6 DO BMES^XPDUTL("Attaching ""RHI1"" option to the Registration Reports menu ""RPT"".")
+7 IF $$ADD^XPDMENU("AGREPORTS","AGRHI1","RHI1",20)
DO BMES^XPDUTL("....successfully atch'd.")
IF 1
+8 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+9 ;
+10 QUIT
+11 ;
TS DO MES^XPDUTL($$HTE^XLFDT($HOROLOG))
QUIT
+1 ;
AGFAC ; FEED NEW REGISTRATION PARAMETERS IF BLANK
+1 SET AGFAC=0
+2 FOR
SET AGFAC=$ORDER(^AGFAC("B",AGFAC))
IF 'AGFAC
QUIT
Begin DoDot:1
+3 SET AGFACPTR=0
+4 FOR
SET AGFACPTR=$ORDER(^AGFAC("B",AGFAC,AGFACPTR))
IF 'AGFACPTR
QUIT
Begin DoDot:2
+5 IF $PIECE($GET(^AGFAC(AGFACPTR,0)),U,22)=""
SET $PIECE(^AGFAC(AGFACPTR,0),U,22)=0
+6 IF $PIECE($GET(^AGFAC(AGFACPTR,0)),U,23)=""
SET $PIECE(^AGFAC(AGFACPTR,0),U,23)="N"
+7 IF $PIECE($GET(^AGFAC(AGFACPTR,0)),U,24)=""
SET $PIECE(^AGFAC(AGFACPTR,0),U,24)="N"
End DoDot:2
End DoDot:1
+8 KILL AGFAC,AGFACPTR
+9 QUIT
PRVT ; FIND ANY PRIVATE ELIG MISSING INSURER POINTER
+1 SET RECNO=0
+2 FOR
SET RECNO=$ORDER(^AUPNPRVT(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+3 SET D1=0
+4 FOR
SET D1=$ORDER(^AUPNPRVT(RECNO,11,D1))
IF 'D1
QUIT
Begin DoDot:2
+5 IF $PIECE($GET(^AUPNPRVT(RECNO,11,D1,0)),U,1)=""
Begin DoDot:3
+6 KILL ^AUPNPRVT(RECNO,11,D1,0)
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
MCD ; FIND MCD MISSING .01 FIELD
+1 SET RECNO=0
+2 FOR
SET RECNO=$ORDER(^AUPNMCD(RECNO))
IF 'RECNO
QUIT
Begin DoDot:1
+3 SET MCDREC=$GET(^AUPNMCD(RECNO,0))
+4 IF $PIECE(MCDREC,U,1)=""
KILL ^AUPNMCD(RECNO,0)
End DoDot:1
+5 QUIT
