PRCAI217.m

PRCAI217 ;ALB/CXW - PRCA*4.5*217 POST-INIT ROUTINE

 ;;4.5;Accounts Receivable;**217**;Mar 20, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 Q

EN ;convert the data stored in the global DISV(DUZ,"RCDPRPLM") file to the 

 ;AR USER CUSTOMIZE file (#342.3).

 ;^RC(342.3,da,0)=screen/options

 ;^RC(342.3,da,1,da(1),0)=duz^selection^device

 ;

 N RCDUZ,RCSNOPT,RCREC,RCSEL,RCDEV,U,DA,X,DIC,DIE,DR

 W !

 W "PRCA*4.5*217 Post Install......",!

 W "Converting the data stored in the ^DISV(DUZ,""RCDPRPLM"") global to",!

 W "the AR USER CUSTOMIZE file (#342.3)."

 S RCDUZ=0,U="^"

 F  S RCDUZ=$O(^DISV(RCDUZ)) Q:'RCDUZ  I $D(^DISV(RCDUZ,"RCDPRPLM")) D

 .S RCSNOPT=""

 .L +^DISV(RCDUZ,"RCDPRPLM"):5

 .F  S RCSNOPT=$O(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT)) Q:RCSNOPT=""  D

 ..S RCREC=$G(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT))

 ..I '$D(^RC(342.3,"B",RCSNOPT)) D

 ...K DD,DO,DIC("DR") S DIC="^RC(342.3,",DIC(0)="",X=RCSNOPT

 ...D FILE^DICN

 ..S RCSEL=$S(RCSNOPT="215REPORT":"",1:$P(RCREC,U))

 ..S RCDEV=$S(RCSNOPT="RECEIPT":$P(RCREC,U,2),RCSNOPT="215REPORT":$P(RCREC,U),1:"")

 ..S DA(1)=$O(^RC(342.3,"B",RCSNOPT,0))

 ..;if new then add entry

 ..I '$D(^RC(342.3,DA(1),1,"B",RCDUZ)) D  Q

 ...S DIC(0)="",DIC("P")=$P(^DD(342.3,1,0),U,2)

 ...S DIC="^RC(342.3,"_DA(1)_",1,"

 ...S X=RCDUZ

 ...S DIC("DR")="1////"_RCSEL_";2////"_RCDEV

 ...K DD,DO D FILE^DICN

 ...;

 ..;if existing then edit entry

 ..S DA=$O(^RC(342.3,DA(1),1,"B",RCDUZ,0)),DR=".01////"_RCDUZ_";1////"_RCSEL_";2////"_RCDEV

 ..S DIE="^RC(342.3,"_DA(1)_",1," D ^DIE

 .W "."

 .L -^DISV(RCDUZ,"RCDPRPLM")

 W "Done!"

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCAI217   1614     printed  Mar 13, 2025@20:44:48                                                                                                                                                                                                    Page 2

PRCAI217  ;ALB/CXW - PRCA*4.5*217 POST-INIT ROUTINE

 +1       ;;4.5;Accounts Receivable;**217**;Mar 20, 1995

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        QUIT 

EN        ;convert the data stored in the global DISV(DUZ,"RCDPRPLM") file to the 

 +1       ;AR USER CUSTOMIZE file (#342.3).

 +2       ;^RC(342.3,da,0)=screen/options

 +3       ;^RC(342.3,da,1,da(1),0)=duz^selection^device

 +4       ;

 +5        NEW RCDUZ,RCSNOPT,RCREC,RCSEL,RCDEV,U,DA,X,DIC,DIE,DR

 +6        WRITE !

 +7        WRITE "PRCA*4.5*217 Post Install......",!

 +8        WRITE "Converting the data stored in the ^DISV(DUZ,""RCDPRPLM"") global to",!

 +9        WRITE "the AR USER CUSTOMIZE file (#342.3)."

 +10       SET RCDUZ=0

           SET U="^"

 +11       FOR 

               SET RCDUZ=$ORDER(^DISV(RCDUZ))

               if 'RCDUZ

                   QUIT 

               IF $DATA(^DISV(RCDUZ,"RCDPRPLM"))

                   Begin DoDot:1

 +12                   SET RCSNOPT=""

 +13                   LOCK +^DISV(RCDUZ,"RCDPRPLM"):5

 +14                   FOR 

                           SET RCSNOPT=$ORDER(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT))

                           if RCSNOPT=""

                               QUIT 

                           Begin DoDot:2

 +15                           SET RCREC=$GET(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT))

 +16                           IF '$DATA(^RC(342.3,"B",RCSNOPT))

                                   Begin DoDot:3

 +17                                   KILL DD,DO,DIC("DR")

                                       SET DIC="^RC(342.3,"

                                       SET DIC(0)=""

                                       SET X=RCSNOPT

 +18                                   DO FILE^DICN

                                   End DoDot:3

 +19                           SET RCSEL=$SELECT(RCSNOPT="215REPORT":"",1:$PIECE(RCREC,U))

 +20                           SET RCDEV=$SELECT(RCSNOPT="RECEIPT":$PIECE(RCREC,U,2),RCSNOPT="215REPORT":$PIECE(RCREC,U),1:"")

 +21                           SET DA(1)=$ORDER(^RC(342.3,"B",RCSNOPT,0))

 +22      ;if new then add entry

 +23                           IF '$DATA(^RC(342.3,DA(1),1,"B",RCDUZ))

                                   Begin DoDot:3

 +24                                   SET DIC(0)=""

                                       SET DIC("P")=$PIECE(^DD(342.3,1,0),U,2)

 +25                                   SET DIC="^RC(342.3,"_DA(1)_",1,"

 +26                                   SET X=RCDUZ

 +27                                   SET DIC("DR")="1////"_RCSEL_";2////"_RCDEV

 +28                                   KILL DD,DO

                                       DO FILE^DICN

 +29      ;

                                   End DoDot:3

                                   QUIT 

 +30      ;if existing then edit entry

 +31                           SET DA=$ORDER(^RC(342.3,DA(1),1,"B",RCDUZ,0))

                               SET DR=".01////"_RCDUZ_";1////"_RCSEL_";2////"_RCDEV

 +32                           SET DIE="^RC(342.3,"_DA(1)_",1,"

                               DO ^DIE

                           End DoDot:2

 +33                   WRITE "."

 +34                   LOCK -^DISV(RCDUZ,"RCDPRPLM")

                   End DoDot:1

 +35       WRITE "Done!"

 +36       QUIT