PXRMWHPI.m

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

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       ;D COND

 +3       ;D REVIEW

 +4        QUIT 

 +5       ;

POST      ;

 +1       ;D INSTALL

 +2       ;D 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