PXRMWHPI ; SLC/AGP - Inits for PXRM*2.0*1 ;11/16/2004
;;2.0;CLINICAL REMINDERS;**1**;Feb 04, 2005
;
Q
PRE ;
D DELEI
D COND
D REVIEW
Q
;
POST ;
D INSTALL
D UPDATE
Q
;
COND ;
N CFIEN,CFNAME,COND,DA,DIE,DR,NAME,NUM,TIEN,PXRMINST
S PXRMINST=1
S CFIEN=$O(^PXRMD(811.4,"B","VA-WH PAP SMEAR IN LAB PKG","")) Q:CFIEN'>0
S CFNAME=CFIEN_";PXRMD(811.4,"
F NAME="VA-WH PAP SMEAR SCREEN IN LAB PKG","VA-WH PAP SMEAR UNSATISFACTORY IN LAB/WH PKG" D
.S TIEN=$O(^PXRMD(811.5,NAME,"")) I TIEN'>0 Q
.S DA(1)=TIEN
.I NAME="VA-WH PAP SMEAR UNSATISFACTORY IN LAB/WH PKG" D
..S COND="I V(""UNSATISFACTORY"")=""T"""
.I NAME="VA-WH PAP SMEAR SCREEN IN LAB PKG" D
..S COND="I V(""UNSATISFACTORY"")=""F"""
.S NUM=0 F S NUM=$O(^PXRMD(811.5,TIEN,20,NUM)) Q:NUM'>0 D Q
..I $G(^PXRMD(811.5,TIEN,20,NUM,0))'[CFNAME Q
..S DA=NUM,DIE="^PXRMD(811.5,"_DA(1)_",20,",DR="14///^S X=COND"
..D ^DIE
Q
;
DELEI ;If the Exchange File entry already exists delete it.
;
N IND,LIST,LUVALUE,NUM
;
;
S LUVALUE(1)="VA-WH MAMMOGRAM REVIEW RESULTS"
D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
S NUM=$P(LIST("DILIST",0),U,1)
I NUM'=0 D
.F IND=1:1:NUM D
.. N DA,DIK
.. S DIK="^PXD(811.8,"
.. S DA=LIST("DILIST",2,IND)
.. D ^DIK
;
S LUVALUE(1)="VA-WH MAMMOGRAM SCREENING"
D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
S NUM=$P(LIST("DILIST",0),U,1)
I NUM'=0 D
.F IND=1:1:NUM D
.. N DA,DIK
.. S DIK="^PXD(811.8,"
.. S DA=LIST("DILIST",2,IND)
.. D ^DIK
;
S LUVALUE(1)="VA-WH PAP SMEAR REVIEW RESULTS"
D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
S NUM=$P(LIST("DILIST",0),U,1)
I NUM'=0 D
.F IND=1:1:NUM D
.. N DA,DIK
.. S DIK="^PXD(811.8,"
.. S DA=LIST("DILIST",2,IND)
.. D ^DIK
;
S LUVALUE(1)="VA-WH PAP SMEAR SCREENING"
D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
S NUM=$P(LIST("DILIST",0),U,1)
I NUM'=0 D
.F IND=1:1:NUM D
.. N DA,DIK
.. S DIK="^PXD(811.8,"
.. S DA=LIST("DILIST",2,IND)
.. D ^DIK
Q
;
REVIEW ;
N TIEN,CFIEN,CFNAME,DA,DIE,DR,NAME,NNAME,NEW,PXRMINST
S PXRMINST=1
S DIE="^PXRMD(811.5,",NEW=1
F NAME="VA-WH MAMMOGRAM PENDING REVIEW ","VA-WH PAP SMEAR PENDING REVIEW" D
.S TIEN=$O(^PXRMD(811.5,"B",NAME,"")) Q:TIEN'>0
.I NAME["MAMMOGRAM" D
..S NNAME="VA-WH MAMMOGRAM PENDING REVIEW",DA=TIEN
..S DR=".01///^S X=NNAME" D ^DIE
..S DA(1)=DA
..S CFIEN=$O(^PXRMD(811.4,"B","VA-WH MAMMOGRAM IN WH PKG","")) Q:CFIEN'>0
..S CFNAME=CFIEN_";PXRMD(811.4,"
..S DA=$O(^PXRMD(811.5,DA(1),20,"B",CFNAME,"")) Q:DA'>0
..S DIE="^PXRMD(811.5,"_DA(1)_",20,",DR="15///^S X=NEW"
..D ^DIE
.I NAME["PAP" D
..S DA(1)=TIEN
..S CFIEN=$O(^PXRMD(811.4,"B","VA-WH PAP SMEAR IN WH PKG","")) Q:CFIEN'>0
..S CFNAME=CFIEN_";PXRMD(811.4,"
..S DA=$O(^PXRMD(811.5,DA(1),20,"B",CFNAME,"")) Q:DA'>0
..S DIE="^PXRMD(811.5,"_DA(1)_",20,",DR="15///^S X=NEW"
..D ^DIE
Q
;
INSTALL ;Silent mode install.
N IEN,LUVALUE
;
S PXRMINST=1
;
S LUVALUE(1)="VA-WH MAMMOGRAM REVIEW RESULTS"
S LUVALUE(2)="02/04/2005@17:11:10"
S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
I IEN'=0 D
. N TEXT
. S TEXT="Installing reminder "_LUVALUE(1)
. D BMES^XPDUTL(TEXT)
. D INSTALL^PXRMEXSI(IEN)
;
;
S LUVALUE(1)="VA-WH MAMMOGRAM SCREENING"
S LUVALUE(2)="02/04/2005@17:11:35"
S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
I IEN'=0 D
. N TEXT
. S TEXT="Installing reminder "_LUVALUE(1)
. D BMES^XPDUTL(TEXT)
. D INSTALL^PXRMEXSI(IEN)
;
;
S LUVALUE(1)="VA-WH PAP SMEAR REVIEW RESULTS"
S LUVALUE(2)="02/04/2005@17:12:10"
S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
I IEN'=0 D
. N TEXT
. S TEXT="Installing reminder "_LUVALUE(1)
. D BMES^XPDUTL(TEXT)
. D INSTALL^PXRMEXSI(IEN)
;
S LUVALUE(1)="VA-WH PAP SMEAR SCREENING"
S LUVALUE(2)="02/04/2005@17:12:52"
S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
I IEN'=0 D
. N TEXT
. S TEXT="Installing reminder "_LUVALUE(1)
. D BMES^XPDUTL(TEXT)
. D INSTALL^PXRMEXSI(IEN)
Q
;
UPDATE ;
N DA,DIE,DR,WHIEN,PIEN,PNAME
S WHIEN=$O(^PXRMD(801.45,"B","WH","")) Q:WHIEN'>0
F PNAME="PXRM WH UPDATE TREATMENT NEED","PXRM WH NOTIFICATION TYPE" D
.S DIE="^PXRMD(801.41,",DR="14////^S X=WHIEN"
.S DA=$O(^PXRMD(801.41,"B",PNAME,"")) Q:DA'>0
.D ^DIE
.W !,"UPDATING FORCE VALUE: "_PNAME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMWHPI 4338 printed Dec 13, 2024@01:50:05 Page 2
PXRMWHPI ; SLC/AGP - Inits for PXRM*2.0*1 ;11/16/2004
+1 ;;2.0;CLINICAL REMINDERS;**1**;Feb 04, 2005
+2 ;
+3 QUIT
PRE ;
+1 DO DELEI
+2 DO COND
+3 DO REVIEW
+4 QUIT
+5 ;
POST ;
+1 DO INSTALL
+2 DO UPDATE
+3 QUIT
+4 ;
COND ;
+1 NEW CFIEN,CFNAME,COND,DA,DIE,DR,NAME,NUM,TIEN,PXRMINST
+2 SET PXRMINST=1
+3 SET CFIEN=$ORDER(^PXRMD(811.4,"B","VA-WH PAP SMEAR IN LAB PKG",""))
if CFIEN'>0
QUIT
+4 SET CFNAME=CFIEN_";PXRMD(811.4,"
+5 FOR NAME="VA-WH PAP SMEAR SCREEN IN LAB PKG","VA-WH PAP SMEAR UNSATISFACTORY IN LAB/WH PKG"
Begin DoDot:1
+6 SET TIEN=$ORDER(^PXRMD(811.5,NAME,""))
IF TIEN'>0
QUIT
+7 SET DA(1)=TIEN
+8 IF NAME="VA-WH PAP SMEAR UNSATISFACTORY IN LAB/WH PKG"
Begin DoDot:2
+9 SET COND="I V(""UNSATISFACTORY"")=""T"""
End DoDot:2
+10 IF NAME="VA-WH PAP SMEAR SCREEN IN LAB PKG"
Begin DoDot:2
+11 SET COND="I V(""UNSATISFACTORY"")=""F"""
End DoDot:2
+12 SET NUM=0
FOR
SET NUM=$ORDER(^PXRMD(811.5,TIEN,20,NUM))
if NUM'>0
QUIT
Begin DoDot:2
+13 IF $GET(^PXRMD(811.5,TIEN,20,NUM,0))'[CFNAME
QUIT
+14 SET DA=NUM
SET DIE="^PXRMD(811.5,"_DA(1)_",20,"
SET DR="14///^S X=COND"
+15 DO ^DIE
End DoDot:2
QUIT
End DoDot:1
+16 QUIT
+17 ;
DELEI ;If the Exchange File entry already exists delete it.
+1 ;
+2 NEW IND,LIST,LUVALUE,NUM
+3 ;
+4 ;
+5 SET LUVALUE(1)="VA-WH MAMMOGRAM REVIEW RESULTS"
+6 DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
+7 SET NUM=$PIECE(LIST("DILIST",0),U,1)
+8 IF NUM'=0
Begin DoDot:1
+9 FOR IND=1:1:NUM
Begin DoDot:2
+10 NEW DA,DIK
+11 SET DIK="^PXD(811.8,"
+12 SET DA=LIST("DILIST",2,IND)
+13 DO ^DIK
End DoDot:2
End DoDot:1
+14 ;
+15 SET LUVALUE(1)="VA-WH MAMMOGRAM SCREENING"
+16 DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
+17 SET NUM=$PIECE(LIST("DILIST",0),U,1)
+18 IF NUM'=0
Begin DoDot:1
+19 FOR IND=1:1:NUM
Begin DoDot:2
+20 NEW DA,DIK
+21 SET DIK="^PXD(811.8,"
+22 SET DA=LIST("DILIST",2,IND)
+23 DO ^DIK
End DoDot:2
End DoDot:1
+24 ;
+25 SET LUVALUE(1)="VA-WH PAP SMEAR REVIEW RESULTS"
+26 DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
+27 SET NUM=$PIECE(LIST("DILIST",0),U,1)
+28 IF NUM'=0
Begin DoDot:1
+29 FOR IND=1:1:NUM
Begin DoDot:2
+30 NEW DA,DIK
+31 SET DIK="^PXD(811.8,"
+32 SET DA=LIST("DILIST",2,IND)
+33 DO ^DIK
End DoDot:2
End DoDot:1
+34 ;
+35 SET LUVALUE(1)="VA-WH PAP SMEAR SCREENING"
+36 DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
+37 SET NUM=$PIECE(LIST("DILIST",0),U,1)
+38 IF NUM'=0
Begin DoDot:1
+39 FOR IND=1:1:NUM
Begin DoDot:2
+40 NEW DA,DIK
+41 SET DIK="^PXD(811.8,"
+42 SET DA=LIST("DILIST",2,IND)
+43 DO ^DIK
End DoDot:2
End DoDot:1
+44 QUIT
+45 ;
REVIEW ;
+1 NEW TIEN,CFIEN,CFNAME,DA,DIE,DR,NAME,NNAME,NEW,PXRMINST
+2 SET PXRMINST=1
+3 SET DIE="^PXRMD(811.5,"
SET NEW=1
+4 FOR NAME="VA-WH MAMMOGRAM PENDING REVIEW ","VA-WH PAP SMEAR PENDING REVIEW"
Begin DoDot:1
+5 SET TIEN=$ORDER(^PXRMD(811.5,"B",NAME,""))
if TIEN'>0
QUIT
+6 IF NAME["MAMMOGRAM"
Begin DoDot:2
+7 SET NNAME="VA-WH MAMMOGRAM PENDING REVIEW"
SET DA=TIEN
+8 SET DR=".01///^S X=NNAME"
DO ^DIE
+9 SET DA(1)=DA
+10 SET CFIEN=$ORDER(^PXRMD(811.4,"B","VA-WH MAMMOGRAM IN WH PKG",""))
if CFIEN'>0
QUIT
+11 SET CFNAME=CFIEN_";PXRMD(811.4,"
+12 SET DA=$ORDER(^PXRMD(811.5,DA(1),20,"B",CFNAME,""))
if DA'>0
QUIT
+13 SET DIE="^PXRMD(811.5,"_DA(1)_",20,"
SET DR="15///^S X=NEW"
+14 DO ^DIE
End DoDot:2
+15 IF NAME["PAP"
Begin DoDot:2
+16 SET DA(1)=TIEN
+17 SET CFIEN=$ORDER(^PXRMD(811.4,"B","VA-WH PAP SMEAR IN WH PKG",""))
if CFIEN'>0
QUIT
+18 SET CFNAME=CFIEN_";PXRMD(811.4,"
+19 SET DA=$ORDER(^PXRMD(811.5,DA(1),20,"B",CFNAME,""))
if DA'>0
QUIT
+20 SET DIE="^PXRMD(811.5,"_DA(1)_",20,"
SET DR="15///^S X=NEW"
+21 DO ^DIE
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
INSTALL ;Silent mode install.
+1 NEW IEN,LUVALUE
+2 ;
+3 SET PXRMINST=1
+4 ;
+5 SET LUVALUE(1)="VA-WH MAMMOGRAM REVIEW RESULTS"
+6 SET LUVALUE(2)="02/04/2005@17:11:10"
+7 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+8 IF IEN'=0
Begin DoDot:1
+9 NEW TEXT
+10 SET TEXT="Installing reminder "_LUVALUE(1)
+11 DO BMES^XPDUTL(TEXT)
+12 DO INSTALL^PXRMEXSI(IEN)
End DoDot:1
+13 ;
+14 ;
+15 SET LUVALUE(1)="VA-WH MAMMOGRAM SCREENING"
+16 SET LUVALUE(2)="02/04/2005@17:11:35"
+17 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+18 IF IEN'=0
Begin DoDot:1
+19 NEW TEXT
+20 SET TEXT="Installing reminder "_LUVALUE(1)
+21 DO BMES^XPDUTL(TEXT)
+22 DO INSTALL^PXRMEXSI(IEN)
End DoDot:1
+23 ;
+24 ;
+25 SET LUVALUE(1)="VA-WH PAP SMEAR REVIEW RESULTS"
+26 SET LUVALUE(2)="02/04/2005@17:12:10"
+27 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+28 IF IEN'=0
Begin DoDot:1
+29 NEW TEXT
+30 SET TEXT="Installing reminder "_LUVALUE(1)
+31 DO BMES^XPDUTL(TEXT)
+32 DO INSTALL^PXRMEXSI(IEN)
End DoDot:1
+33 ;
+34 SET LUVALUE(1)="VA-WH PAP SMEAR SCREENING"
+35 SET LUVALUE(2)="02/04/2005@17:12:52"
+36 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+37 IF IEN'=0
Begin DoDot:1
+38 NEW TEXT
+39 SET TEXT="Installing reminder "_LUVALUE(1)
+40 DO BMES^XPDUTL(TEXT)
+41 DO INSTALL^PXRMEXSI(IEN)
End DoDot:1
+42 QUIT
+43 ;
UPDATE ;
+1 NEW DA,DIE,DR,WHIEN,PIEN,PNAME
+2 SET WHIEN=$ORDER(^PXRMD(801.45,"B","WH",""))
if WHIEN'>0
QUIT
+3 FOR PNAME="PXRM WH UPDATE TREATMENT NEED","PXRM WH NOTIFICATION TYPE"
Begin DoDot:1
+4 SET DIE="^PXRMD(801.41,"
SET DR="14////^S X=WHIEN"
+5 SET DA=$ORDER(^PXRMD(801.41,"B",PNAME,""))
if DA'>0
QUIT
+6 DO ^DIE
+7 WRITE !,"UPDATING FORCE VALUE: "_PNAME
End DoDot:1
+8 QUIT
